DGRRLU3 ;alb/aas - DG Replacement and Rehosting RPC for VADPT ;8/8/05  15:38
 ;;5.3;Registration;**538**;Aug 13, 1993
 ;
 
QUIT
 
; -- Get list of wards or clinics for patient lookup by ward
 ;
 ; -- Does not currently limit display by division, institution, etc.  May need to.
 ;
GETLIST(RESULT,PARAM) ;
 ; Input: PARAM("TYPE")="ward" returns a list of wards
 ;        PARAM("TYPE")="clinic" returns a list of clinics
 ;        PARAM("TYPE")="provider" returns a list of providers 
 ;        PARAM("TYPE")="specialty" returns a list of specialties
 ;        PARAM("VALUE")= Beginning lookup value or null to start
 ;                         at the beginning or end of the file.
 ;        PARAM("MAXNUM")= Number of records to be returned.  If a
 ;                          negative number, traverse backwards.
 ;
 
NEW X,CNT,DGRRLINE,DGRRESLT,OKAY
 
SET (CNT,OKAY)=0
 
IF '$D(DTDT^DICRW
 
;
 
SET DGRRLINE=0
 
^TMP($J,"PLU-FILTER")
 
SET DGRRESLT="^TMP($J,""PLU-FILTER"")"
 
SET RESULT=$NA(@DGRRESLT)
 
;
 
DO ADD^DGRRUTL($$XMLHDR^DGRRUTL)
 
;
 
IF $$UP^XLFSTR($G(PARAM("TYPE")))="WARD" OKAY=1 D
 
ADD^DGRRUTL("<filterlist type='ward'>")
 . 
WLIST("ward",$G(PARAM("VALUE")),$G(PARAM("MAXNUM")))
 . 
ADD^DGRRUTL("</filterlist>")
 
;
 
IF $$UP^XLFSTR($G(PARAM("TYPE")))="CLINIC" OKAY=2 D
 
ADD^DGRRUTL("<filterlist type='clinic'>")
 . 
CLIST("clinic","C",$G(PARAM("VALUE")),$G(PARAM("MAXNUM")))
 . 
ADD^DGRRUTL("</filterlist>")
 
;
 
IF $$UP^XLFSTR($G(PARAM("TYPE")))="PROVIDER" OKAY=3 D
 
ADD^DGRRUTL("<filterlist type='provider'>")
 . 
PLIST("provider",$G(PARAM("VALUE")),$G(PARAM("MAXNUM")))
 . 
ADD^DGRRUTL("</filterlist>")
 
;
 
IF $$UP^XLFSTR($G(PARAM("TYPE")))="SPECIALTY" OKAY=4 D
 
ADD^DGRRUTL("<filterlist type='specialty'>")
 . 
SLIST("specialty",$G(PARAM("VALUE")),$G(PARAM("MAXNUM")))
 . 
ADD^DGRRUTL("</filterlist>")
 
;
 
IF OKAY<1 D
 
ADD^DGRRUTL("<unspecified>")
 . 
ADD^DGRRUTL("<error message='List type not supported or not specified!'>")
 . 
ADD^DGRRUTL("</unspecified>")
 
;
 
QUIT
 
;
 ; -- get list of clinics for patient lookup by clinic
CLIST(ITEM,CHKVAL,VALUE,MAXNUM) ;
 
NEW NAME,IEN,IDATE,RDATE,DIR,CNT2,DGRRB,FLAG
 
VALUE=$$UP^XLFSTR($G(VALUE))
 
NAME=$G(VALUE)
 
MAXNUM=$G(MAXNUM)
 
DGRRB=0
 
^TMP("DGRRLU3-CLIST",$J)
 
I $E(MAXNUM)="-" D
 
DGRRB=1  ; ****
 
.MAXNUM="-" MAXNUM="" Q  ; ****
 
.MAXNUM=$$ABS^XLFMTH(MAXNUM)
 
(FLAG,CNT)=0
 
I $L(NAME)>0,DGRRB=0,$D(^SC("B",NAME)) NAME=$O(^SC("B",NAME),-1) ; ****
 
I $L(NAME)>0,DGRRB=1,$D(^SC("B",NAME)) NAME=$O(^SC("B",NAME)) ; ****
 
'DGRRB D
 
DIR=1
 .
FOR  S NAME=$O(^SC("B",NAME)) Q:NAME=""  DO  Q:FLAG=1
 .. 
IEN=0
 .. 
FOR  S IEN=$O(^SC("B",NAME,IEN)) Q:IEN<1  DO  Q:FLAG=1
 ...
STATUS
 
...STATUS=$$STATUS(IEN,CHKVAL)
 ...
STATUS=1 D
 
....CNT=CNT+1  MAXNUM,CNT>MAXNUM FLAG=1 Q   ; ****
 
.... ;DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
 
.... ^TMP("DGRRLU3-CLIST",$J,CNT)=IEN_U_NAME
 
DGRRB D
 
DIR=-1
 .
FOR  S NAME=$O(^SC("B",NAME),-1) Q:NAME=""  DO  Q:FLAG=1
 .. 
IEN=0
 .. 
FOR  S IEN=$O(^SC("B",NAME,IEN)) Q:IEN<1  DO  Q:FLAG=1
 ...
STATUS
 
...STATUS=$$STATUS(IEN,CHKVAL)
 ...
STATUS=1 D
 
....CNT=CNT+1  MAXNUM,CNT>MAXNUM FLAG=1 Q   ; ****
 
.... ; DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
 
.... ^TMP("DGRRLU3-CLIST",$J,CNT)=IEN_U_NAME
 
CNT2="",CNT=0
 
F  S CNT2=$O(^TMP("DGRRLU3-CLIST",$J,CNT2),DIRQ:CNT2=""  D
 
IEN=+^TMP("DGRRLU3-CLIST",$J,CNT2)
 . 
NAME=$P(^TMP("DGRRLU3-CLIST",$J,CNT2),U,2)
 . 
CNT=CNT+1
 . 
DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
 
QUIT
STATUS(IEN,CHKVAL) ;
 
IDATE,RDATE,STATUS
 
STATUS=0
 
IF $P($G(^SC(IEN,0)),"^",3)=CHKVAL DO  ;is a clinic
 
.IDATE=$P($G(^SC(IEN,"I")),"^",1) ;inactivate date
 
.RDATE=$P($G(^SC(IEN,"I")),"^",2) ;reactivate date
 
.IF (IDATE="")!(IDATE'<DT)!((IDATE<DT)&(RDATE>IDATE)) STATUS=1
 
STATUS
 
;
WLIST(ITEM,VALUE,MAXNUM) ;
 ;  Input:  VALUE - Beginning value or null to start at the beginning
 ;                  or end of the file.
 ;         MAXNUM - Number of entries to be returned.  Defaults to
 ;                  traversing forward but if MAXNUM is a negative
 ;                  number, traverses through the file backwards.
 
FLAG,ERROR,CNT,DGRRB,BACKMTCH,CNT2
 
CNT=0
 
;I VALUE is null and MAXNUM is set to "-" or null, all wards returned
 
VALUE=$$UP^XLFSTR($G(VALUE))
 
MAXNUM=$G(MAXNUM)
 
FLAG=""
 
I $E(MAXNUM)="-" D
 
.;Set direction for traversing file to backwards and remove - from
 
.;maximum number of records returned.
 
.FLAG="B"
 
.MAXNUM="-" MAXNUM="" Q
 
.MAXNUM=$$ABS^XLFMTH(MAXNUM)
 
;Look for exact match
 
^TMP("DILIST",$J)
 
($G(VALUE)'=""EXMTCH
 
;Call File Manager for remaining matches
 ; K ^TMP("DILIST",$J)
 
MAXNUM'=0 LIST^DIC(42,,.01,$G(FLAG),MAXNUM,VALUE,,"B",,,,"ERROR")
 
Q:$D(ERROR)
 
DGRRI
 
DGRRI=""
 
I $G(BACKMTCHD
 
^TMP("DILIST",$J,2,"ZZ")=+BACKMTCH
 
^TMP("DILIST",$J,1,"ZZ")=$P(BACKMTCH,U,2)
 
DGRRB=1 ; I FLAG="B" S DGRRB=-1
 
F  S DGRRI=$O(^TMP("DILIST",$J,1,DGRRI),DGRRBQ:DGRRI=""  D
 
.IEN,NAME
 
.CNT=CNT+1
 .
NAME=$G(^TMP("DILIST",$J,1,DGRRI))
 .
IEN=$G(^TMP("DILIST",$J,2,DGRRI))
 .
DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
 
; I FLAG="B",($G(VALUE)'="") D EXMTCH
 
Q
EXMTCH ;Look for exact match
 
I $D(^DIC(42,"B",VALUE)) D
 
.IEN
 
.IEN=0
 .
F  S IEN=$O(^DIC(42,"B",VALUE,IEN)) Q:IEN=""  D
 
..NAME
 
..NAME=$P($G(^DIC(42,+IEN,0)),U)
 .. 
; S CNT=CNT+1
 
.. MAXNUM'="" MAXNUM=MAXNUM-1
 .. 
FLAG'="B" CNT=CNT+1 DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
 .. 
FLAG="B" BACKMTCH=IEN_U_NAME
 
Q
 
; -- get list of providers for patient lookup by provider
 ;    from ORQPTQ2
PLIST(ITEM,VALUE,MAXNUM) ;
 
NEW NAME,IEN,DGRRB,FLAG,CNT2,DGRRSCR,DGRRFMT
 
VALUE=$$UP^XLFSTR($G(VALUE))
 
NAME=$G(VALUE)
 
MAXNUM=$G(MAXNUM)
 
DGRRB=1
 
;K ^TMP("DGRRLU3-PLIST",$J)
 
^TMP("DILIST",$J)
 
I $E(MAXNUM)="-" D
 
DGRRB=-1  ; *****
 
MAXNUM="-" MAXNUM="" Q  ; *****
 
.MAXNUM=$$ABS^XLFMTH(MAXNUM)
 
(FLAG,CNT)=0
 
;I $L(NAME)>0,DGRRB=1,$D(^VA(200,"B",NAME)) S NAME=$O(^VA(200,"B",NAME),-1)
 ;I $L(NAME)>0,DGRRB=-1,$D(^VA(200,"B",NAME)) S NAME=$O(^VA(200,"B",NAME))
 ;FOR  S NAME=$O(^VA(200,"B",NAME),DGRRB) Q:NAME=""  DO  Q:FLAG=1
 ;. S IEN=0
 ;. FOR  S IEN=$O(^VA(200,"B",NAME,IEN)) Q:IEN<1  DO  Q:FLAG=1
 ;.. I $D(^XUSEC("PROVIDER",IEN)),$$ACTIVE^XUSER(IEN) DO
 ;... SET CNT=CNT+1
 ;... S ^TMP("DGRRLU3-PLIST",$J,CNT)=IEN_U_NAME
 ;... I MAXNUM,CNT>(MAXNUM-1) S FLAG=1
 ;S CNT2="",CNT=0
 ;F  S CNT2=$O(^TMP("DGRRLU3-PLIST",$J,CNT2),DGRRB) Q:CNT2=""  D
 ;. S IEN=+^TMP("DGRRLU3-PLIST",$J,CNT2)
 ;. S NAME=$P(^TMP("DGRRLU3-PLIST",$J,CNT2),U,2)
 ;. S CNT=CNT+1
 ;. DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
 
I $L(NAME)>0,DGRRB=1,$D(^VA(200,"AK.PROVIDER",NAME)) NAME=$O(^VA(200,"AK.PROVIDER",NAME),-1)
 
I $L(NAME)>0,DGRRB=-1,$D(^VA(200,"AK.PROVIDER",NAME)) NAME=$O(^VA(200,"AK.PROVIDER",NAME))
 
DGRRSCR="I $$ACTIVE^XUSER(+Y)"
 
DGRRFMT="P"_$S(DGRRB=-1:"B",1:"")
 
LIST^DIC(200,,"@;.01",DGRRFMT,MAXNUM,NAME,,"AK.PROVIDER",DGRRSCR)
 
(CNT2,CNT)=0
 
F  S CNT2=$O(^TMP("DILIST",$J,CNT2)) Q:CNT2=""  D
 
IEN=+$G(^TMP("DILIST",$J,CNT2,0))
 . 
NAME=$P($G(^TMP("DILIST",$J,CNT2,0)),U,2)
 . 
CNT=CNT+1
 . 
DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
 
^TMP("DILIST",$J)
 
CLEAN^DILF
 
QUIT
 
;
SLIST(ITEM,VALUE,MAXNUM) ;Returns active specialties in Facility TreatingSpecialty (#45.7) file
 ;
 
NAME,IEN,CNT,FLAG,DGRRB,DGRRD,CNT2
 
NAME=$$UP^XLFSTR($G(VALUE))
 
; S NAME=$G(VALUE)
 
(FLAG,IEN,CNT)=0
 
MAXNUM=$G(MAXNUM)
 
DGRRB=1
 
^TMP("DGRRLU3-SLIST",$J)
 
I $E(MAXNUM)="-" D
 
.DGRRB=-1
 .
MAXNUM=$$ABS^XLFMTH(MAXNUM)
 
;Capture exact matches
 
I $L(NAME),$D(^DIC(45.7,"B",NAME)) D
 
.DGRRD
 
.DGRRD=$S(DGRRB=1:-1,1:1)
 .
NAME=$O(^DIC(45.7,"B",NAME),DGRRD)
 
F  S NAME=$O(^DIC(45.7,"B",NAME),DGRRBQ:NAME=""  D  Q:FLAG=1
 .
F  S IEN=$O(^DIC(45.7,"B",NAME,IEN)) Q:IEN'>0  D  Q:FLAG=1
 ..
I $$ACTIVE^DGACT(45.7,IEND
 
...CNT=CNT+1
 ...
MAXNUM,(CNT>MAXNUMFLAG=1 Q
 
...; DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
 
...^TMP("DGRRLU3-SLIST",$J,CNT)=IEN_U_NAME
 
CNT=1,CNT2=""
 
DGRRD=$S(DGRRB=1:1,1:-1)
 
F  S CNT2=$O(^TMP("DGRRLU3-SLIST",$J,CNT2),DGRRDQ:CNT2=""  D
 
IEN=+^TMP("DGRRLU3-SLIST",$J,CNT2)
 . 
NAME=$P(^TMP("DGRRLU3-SLIST",$J,CNT2),U,2)
 . 
DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
 . 
CNT=CNT+1
 
Q
 
;
DISPLAY(RESULT) ;
 
NEW I
 
I=-1 FOR  SET I=$O(@RESULT@(I)) Q:I<1  !!,@RESULT@(I)
 
QUIT