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(DT) D DT^DICRW
;
SET DGRRLINE=0
K ^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" S OKAY=1 D
. D ADD^DGRRUTL("<filterlist type='ward'>")
. D WLIST("ward",$G(PARAM("VALUE")),$G(PARAM("MAXNUM")))
. D ADD^DGRRUTL("</filterlist>")
;
IF $$UP^XLFSTR($G(PARAM("TYPE")))="CLINIC" S OKAY=2 D
. D ADD^DGRRUTL("<filterlist type='clinic'>")
. D CLIST("clinic","C",$G(PARAM("VALUE")),$G(PARAM("MAXNUM")))
. D ADD^DGRRUTL("</filterlist>")
;
IF $$UP^XLFSTR($G(PARAM("TYPE")))="PROVIDER" S OKAY=3 D
. D ADD^DGRRUTL("<filterlist type='provider'>")
. D PLIST("provider",$G(PARAM("VALUE")),$G(PARAM("MAXNUM")))
. D ADD^DGRRUTL("</filterlist>")
;
IF $$UP^XLFSTR($G(PARAM("TYPE")))="SPECIALTY" S OKAY=4 D
. D ADD^DGRRUTL("<filterlist type='specialty'>")
. D SLIST("specialty",$G(PARAM("VALUE")),$G(PARAM("MAXNUM")))
. D ADD^DGRRUTL("</filterlist>")
;
IF OKAY<1 D
. D ADD^DGRRUTL("<unspecified>")
. D ADD^DGRRUTL("<error message='List type not supported or not specified!'>")
. D 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
S VALUE=$$UP^XLFSTR($G(VALUE))
S NAME=$G(VALUE)
S MAXNUM=$G(MAXNUM)
S DGRRB=0
K ^TMP("DGRRLU3-CLIST",$J)
I $E(MAXNUM)="-" D
. S DGRRB=1 ; ****
.I MAXNUM="-" S MAXNUM="" Q ; ****
.S MAXNUM=$$ABS^XLFMTH(MAXNUM)
S (FLAG,CNT)=0
I $L(NAME)>0,DGRRB=0,$D(^SC("B",NAME)) S NAME=$O(^SC("B",NAME),-1) ; ****
I $L(NAME)>0,DGRRB=1,$D(^SC("B",NAME)) S NAME=$O(^SC("B",NAME)) ; ****
I 'DGRRB D
. S DIR=1
.FOR S NAME=$O(^SC("B",NAME)) Q:NAME="" DO Q:FLAG=1
.. S IEN=0
.. FOR S IEN=$O(^SC("B",NAME,IEN)) Q:IEN<1 DO Q:FLAG=1
...N STATUS
...S STATUS=$$STATUS(IEN,CHKVAL)
...I STATUS=1 D
....S CNT=CNT+1 I MAXNUM,CNT>MAXNUM S FLAG=1 Q ; ****
.... ;DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
.... S ^TMP("DGRRLU3-CLIST",$J,CNT)=IEN_U_NAME
I DGRRB D
. S DIR=-1
.FOR S NAME=$O(^SC("B",NAME),-1) Q:NAME="" DO Q:FLAG=1
.. S IEN=0
.. FOR S IEN=$O(^SC("B",NAME,IEN)) Q:IEN<1 DO Q:FLAG=1
...N STATUS
...S STATUS=$$STATUS(IEN,CHKVAL)
...I STATUS=1 D
....S CNT=CNT+1 I MAXNUM,CNT>MAXNUM S FLAG=1 Q ; ****
.... ; DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
.... S ^TMP("DGRRLU3-CLIST",$J,CNT)=IEN_U_NAME
S CNT2="",CNT=0
F S CNT2=$O(^TMP("DGRRLU3-CLIST",$J,CNT2),DIR) Q:CNT2="" D
. S IEN=+^TMP("DGRRLU3-CLIST",$J,CNT2)
. S NAME=$P(^TMP("DGRRLU3-CLIST",$J,CNT2),U,2)
. S CNT=CNT+1
. DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
QUIT
STATUS(IEN,CHKVAL) ;
N IDATE,RDATE,STATUS
S STATUS=0
IF $P($G(^SC(IEN,0)),"^",3)=CHKVAL DO ;is a clinic
.S IDATE=$P($G(^SC(IEN,"I")),"^",1) ;inactivate date
.S RDATE=$P($G(^SC(IEN,"I")),"^",2) ;reactivate date
.IF (IDATE="")!(IDATE'<DT)!((IDATE<DT)&(RDATE>IDATE)) S STATUS=1
Q 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.
N FLAG,ERROR,CNT,DGRRB,BACKMTCH,CNT2
S CNT=0
;I VALUE is null and MAXNUM is set to "-" or null, all wards returned
S VALUE=$$UP^XLFSTR($G(VALUE))
S MAXNUM=$G(MAXNUM)
S FLAG=""
I $E(MAXNUM)="-" D
.;Set direction for traversing file to backwards and remove - from
.;maximum number of records returned.
.S FLAG="B"
.I MAXNUM="-" S MAXNUM="" Q
.S MAXNUM=$$ABS^XLFMTH(MAXNUM)
;Look for exact match
K ^TMP("DILIST",$J)
I ($G(VALUE)'="") D EXMTCH
;Call File Manager for remaining matches
; K ^TMP("DILIST",$J)
I MAXNUM'=0 D LIST^DIC(42,,.01,$G(FLAG),MAXNUM,VALUE,,"B",,,,"ERROR")
Q:$D(ERROR)
N DGRRI
S DGRRI=""
I $G(BACKMTCH) D
. S ^TMP("DILIST",$J,2,"ZZ")=+BACKMTCH
. S ^TMP("DILIST",$J,1,"ZZ")=$P(BACKMTCH,U,2)
S DGRRB=1 ; I FLAG="B" S DGRRB=-1
F S DGRRI=$O(^TMP("DILIST",$J,1,DGRRI),DGRRB) Q:DGRRI="" D
.N IEN,NAME
.S CNT=CNT+1
.S NAME=$G(^TMP("DILIST",$J,1,DGRRI))
.S 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
.N IEN
.S IEN=0
.F S IEN=$O(^DIC(42,"B",VALUE,IEN)) Q:IEN="" D
..N NAME
..S NAME=$P($G(^DIC(42,+IEN,0)),U)
.. ; S CNT=CNT+1
.. I MAXNUM'="" S MAXNUM=MAXNUM-1
.. I FLAG'="B" S CNT=CNT+1 DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
.. I FLAG="B" S 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
S VALUE=$$UP^XLFSTR($G(VALUE))
S NAME=$G(VALUE)
S MAXNUM=$G(MAXNUM)
S DGRRB=1
;K ^TMP("DGRRLU3-PLIST",$J)
K ^TMP("DILIST",$J)
I $E(MAXNUM)="-" D
. S DGRRB=-1 ; *****
. I MAXNUM="-" S MAXNUM="" Q ; *****
.S MAXNUM=$$ABS^XLFMTH(MAXNUM)
S (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)) S NAME=$O(^VA(200,"AK.PROVIDER",NAME),-1)
I $L(NAME)>0,DGRRB=-1,$D(^VA(200,"AK.PROVIDER",NAME)) S NAME=$O(^VA(200,"AK.PROVIDER",NAME))
S DGRRSCR="I $$ACTIVE^XUSER(+Y)"
S DGRRFMT="P"_$S(DGRRB=-1:"B",1:"")
D LIST^DIC(200,,"@;.01",DGRRFMT,MAXNUM,NAME,,"AK.PROVIDER",DGRRSCR)
S (CNT2,CNT)=0
F S CNT2=$O(^TMP("DILIST",$J,CNT2)) Q:CNT2="" D
. S IEN=+$G(^TMP("DILIST",$J,CNT2,0))
. S NAME=$P($G(^TMP("DILIST",$J,CNT2,0)),U,2)
. S CNT=CNT+1
. DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
K ^TMP("DILIST",$J)
D CLEAN^DILF
QUIT
;
SLIST(ITEM,VALUE,MAXNUM) ;Returns active specialties in Facility TreatingSpecialty (#45.7) file
;
N NAME,IEN,CNT,FLAG,DGRRB,DGRRD,CNT2
S NAME=$$UP^XLFSTR($G(VALUE))
; S NAME=$G(VALUE)
S (FLAG,IEN,CNT)=0
S MAXNUM=$G(MAXNUM)
S DGRRB=1
K ^TMP("DGRRLU3-SLIST",$J)
I $E(MAXNUM)="-" D
.S DGRRB=-1
.S MAXNUM=$$ABS^XLFMTH(MAXNUM)
;Capture exact matches
I $L(NAME),$D(^DIC(45.7,"B",NAME)) D
.N DGRRD
.S DGRRD=$S(DGRRB=1:-1,1:1)
.S NAME=$O(^DIC(45.7,"B",NAME),DGRRD)
F S NAME=$O(^DIC(45.7,"B",NAME),DGRRB) Q: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,IEN) D
...S CNT=CNT+1
...I MAXNUM,(CNT>MAXNUM) S FLAG=1 Q
...; DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
...S ^TMP("DGRRLU3-SLIST",$J,CNT)=IEN_U_NAME
S CNT=1,CNT2=""
S DGRRD=$S(DGRRB=1:1,1:-1)
F S CNT2=$O(^TMP("DGRRLU3-SLIST",$J,CNT2),DGRRD) Q:CNT2="" D
. S IEN=+^TMP("DGRRLU3-SLIST",$J,CNT2)
. S NAME=$P(^TMP("DGRRLU3-SLIST",$J,CNT2),U,2)
. DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
. S CNT=CNT+1
Q
;
DISPLAY(RESULT) ;
NEW I
S I=-1 FOR SET I=$O(@RESULT@(I)) Q:I<1 W !!,@RESULT@(I)
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRRLU3 9128 printed Oct 16, 2024@18:58:10 Page 2
DGRRLU3 ;alb/aas - DG Replacement and Rehosting RPC for VADPT ;8/8/05 15:38
+1 ;;5.3;Registration;**538**;Aug 13, 1993
+2 ;
+3 QUIT
+4 ; -- Get list of wards or clinics for patient lookup by ward
+5 ;
+6 ; -- Does not currently limit display by division, institution, etc. May need to.
+7 ;
GETLIST(RESULT,PARAM) ;
+1 ; Input: PARAM("TYPE")="ward" returns a list of wards
+2 ; PARAM("TYPE")="clinic" returns a list of clinics
+3 ; PARAM("TYPE")="provider" returns a list of providers
+4 ; PARAM("TYPE")="specialty" returns a list of specialties
+5 ; PARAM("VALUE")= Beginning lookup value or null to start
+6 ; at the beginning or end of the file.
+7 ; PARAM("MAXNUM")= Number of records to be returned. If a
+8 ; negative number, traverse backwards.
+9 ;
+10 NEW X,CNT,DGRRLINE,DGRRESLT,OKAY
+11 SET (CNT,OKAY)=0
+12 IF '$DATA(DT)
DO DT^DICRW
+13 ;
+14 SET DGRRLINE=0
+15 KILL ^TMP($JOB,"PLU-FILTER")
+16 SET DGRRESLT="^TMP($J,""PLU-FILTER"")"
+17 SET RESULT=$NAME(@DGRRESLT)
+18 ;
+19 DO ADD^DGRRUTL($$XMLHDR^DGRRUTL)
+20 ;
+21 IF $$UP^XLFSTR($GET(PARAM("TYPE")))="WARD"
SET OKAY=1
Begin DoDot:1
+22 DO ADD^DGRRUTL("<filterlist type='ward'>")
+23 DO WLIST("ward",$GET(PARAM("VALUE")),$GET(PARAM("MAXNUM")))
+24 DO ADD^DGRRUTL("</filterlist>")
End DoDot:1
+25 ;
+26 IF $$UP^XLFSTR($GET(PARAM("TYPE")))="CLINIC"
SET OKAY=2
Begin DoDot:1
+27 DO ADD^DGRRUTL("<filterlist type='clinic'>")
+28 DO CLIST("clinic","C",$GET(PARAM("VALUE")),$GET(PARAM("MAXNUM")))
+29 DO ADD^DGRRUTL("</filterlist>")
End DoDot:1
+30 ;
+31 IF $$UP^XLFSTR($GET(PARAM("TYPE")))="PROVIDER"
SET OKAY=3
Begin DoDot:1
+32 DO ADD^DGRRUTL("<filterlist type='provider'>")
+33 DO PLIST("provider",$GET(PARAM("VALUE")),$GET(PARAM("MAXNUM")))
+34 DO ADD^DGRRUTL("</filterlist>")
End DoDot:1
+35 ;
+36 IF $$UP^XLFSTR($GET(PARAM("TYPE")))="SPECIALTY"
SET OKAY=4
Begin DoDot:1
+37 DO ADD^DGRRUTL("<filterlist type='specialty'>")
+38 DO SLIST("specialty",$GET(PARAM("VALUE")),$GET(PARAM("MAXNUM")))
+39 DO ADD^DGRRUTL("</filterlist>")
End DoDot:1
+40 ;
+41 IF OKAY<1
Begin DoDot:1
+42 DO ADD^DGRRUTL("<unspecified>")
+43 DO ADD^DGRRUTL("<error message='List type not supported or not specified!'>")
+44 DO ADD^DGRRUTL("</unspecified>")
End DoDot:1
+45 ;
+46 QUIT
+47 ;
+48 ; -- get list of clinics for patient lookup by clinic
CLIST(ITEM,CHKVAL,VALUE,MAXNUM) ;
+1 NEW NAME,IEN,IDATE,RDATE,DIR,CNT2,DGRRB,FLAG
+2 SET VALUE=$$UP^XLFSTR($GET(VALUE))
+3 SET NAME=$GET(VALUE)
+4 SET MAXNUM=$GET(MAXNUM)
+5 SET DGRRB=0
+6 KILL ^TMP("DGRRLU3-CLIST",$JOB)
+7 IF $EXTRACT(MAXNUM)="-"
Begin DoDot:1
+8 ; ****
SET DGRRB=1
+9 ; ****
IF MAXNUM="-"
SET MAXNUM=""
QUIT
+10 SET MAXNUM=$$ABS^XLFMTH(MAXNUM)
End DoDot:1
+11 SET (FLAG,CNT)=0
+12 ; ****
IF $LENGTH(NAME)>0
IF DGRRB=0
IF $DATA(^SC("B",NAME))
SET NAME=$ORDER(^SC("B",NAME),-1)
+13 ; ****
IF $LENGTH(NAME)>0
IF DGRRB=1
IF $DATA(^SC("B",NAME))
SET NAME=$ORDER(^SC("B",NAME))
+14 IF 'DGRRB
Begin DoDot:1
+15 SET DIR=1
+16 FOR
SET NAME=$ORDER(^SC("B",NAME))
if NAME=""
QUIT
Begin DoDot:2
+17 SET IEN=0
+18 FOR
SET IEN=$ORDER(^SC("B",NAME,IEN))
if IEN<1
QUIT
Begin DoDot:3
+19 NEW STATUS
+20 SET STATUS=$$STATUS(IEN,CHKVAL)
+21 IF STATUS=1
Begin DoDot:4
+22 ; ****
SET CNT=CNT+1
IF MAXNUM
IF CNT>MAXNUM
SET FLAG=1
QUIT
+23 ;DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
+24 SET ^TMP("DGRRLU3-CLIST",$JOB,CNT)=IEN_U_NAME
End DoDot:4
End DoDot:3
if FLAG=1
QUIT
End DoDot:2
if FLAG=1
QUIT
End DoDot:1
+25 IF DGRRB
Begin DoDot:1
+26 SET DIR=-1
+27 FOR
SET NAME=$ORDER(^SC("B",NAME),-1)
if NAME=""
QUIT
Begin DoDot:2
+28 SET IEN=0
+29 FOR
SET IEN=$ORDER(^SC("B",NAME,IEN))
if IEN<1
QUIT
Begin DoDot:3
+30 NEW STATUS
+31 SET STATUS=$$STATUS(IEN,CHKVAL)
+32 IF STATUS=1
Begin DoDot:4
+33 ; ****
SET CNT=CNT+1
IF MAXNUM
IF CNT>MAXNUM
SET FLAG=1
QUIT
+34 ; DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
+35 SET ^TMP("DGRRLU3-CLIST",$JOB,CNT)=IEN_U_NAME
End DoDot:4
End DoDot:3
if FLAG=1
QUIT
End DoDot:2
if FLAG=1
QUIT
End DoDot:1
+36 SET CNT2=""
SET CNT=0
+37 FOR
SET CNT2=$ORDER(^TMP("DGRRLU3-CLIST",$JOB,CNT2),DIR)
if CNT2=""
QUIT
Begin DoDot:1
+38 SET IEN=+^TMP("DGRRLU3-CLIST",$JOB,CNT2)
+39 SET NAME=$PIECE(^TMP("DGRRLU3-CLIST",$JOB,CNT2),U,2)
+40 SET CNT=CNT+1
+41 DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
End DoDot:1
+42 QUIT
STATUS(IEN,CHKVAL) ;
+1 NEW IDATE,RDATE,STATUS
+2 SET STATUS=0
+3 ;is a clinic
IF $PIECE($GET(^SC(IEN,0)),"^",3)=CHKVAL
Begin DoDot:1
+4 ;inactivate date
SET IDATE=$PIECE($GET(^SC(IEN,"I")),"^",1)
+5 ;reactivate date
SET RDATE=$PIECE($GET(^SC(IEN,"I")),"^",2)
+6 IF (IDATE="")!(IDATE'<DT)!((IDATE<DT)&(RDATE>IDATE))
SET STATUS=1
End DoDot:1
+7 QUIT STATUS
+8 ;
WLIST(ITEM,VALUE,MAXNUM) ;
+1 ; Input: VALUE - Beginning value or null to start at the beginning
+2 ; or end of the file.
+3 ; MAXNUM - Number of entries to be returned. Defaults to
+4 ; traversing forward but if MAXNUM is a negative
+5 ; number, traverses through the file backwards.
+6 NEW FLAG,ERROR,CNT,DGRRB,BACKMTCH,CNT2
+7 SET CNT=0
+8 ;I VALUE is null and MAXNUM is set to "-" or null, all wards returned
+9 SET VALUE=$$UP^XLFSTR($GET(VALUE))
+10 SET MAXNUM=$GET(MAXNUM)
+11 SET FLAG=""
+12 IF $EXTRACT(MAXNUM)="-"
Begin DoDot:1
+13 ;Set direction for traversing file to backwards and remove - from
+14 ;maximum number of records returned.
+15 SET FLAG="B"
+16 IF MAXNUM="-"
SET MAXNUM=""
QUIT
+17 SET MAXNUM=$$ABS^XLFMTH(MAXNUM)
End DoDot:1
+18 ;Look for exact match
+19 KILL ^TMP("DILIST",$JOB)
+20 IF ($GET(VALUE)'="")
DO EXMTCH
+21 ;Call File Manager for remaining matches
+22 ; K ^TMP("DILIST",$J)
+23 IF MAXNUM'=0
DO LIST^DIC(42,,.01,$GET(FLAG),MAXNUM,VALUE,,"B",,,,"ERROR")
+24 if $DATA(ERROR)
QUIT
+25 NEW DGRRI
+26 SET DGRRI=""
+27 IF $GET(BACKMTCH)
Begin DoDot:1
+28 SET ^TMP("DILIST",$JOB,2,"ZZ")=+BACKMTCH
+29 SET ^TMP("DILIST",$JOB,1,"ZZ")=$PIECE(BACKMTCH,U,2)
End DoDot:1
+30 ; I FLAG="B" S DGRRB=-1
SET DGRRB=1
+31 FOR
SET DGRRI=$ORDER(^TMP("DILIST",$JOB,1,DGRRI),DGRRB)
if DGRRI=""
QUIT
Begin DoDot:1
+32 NEW IEN,NAME
+33 SET CNT=CNT+1
+34 SET NAME=$GET(^TMP("DILIST",$JOB,1,DGRRI))
+35 SET IEN=$GET(^TMP("DILIST",$JOB,2,DGRRI))
+36 DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
End DoDot:1
+37 ; I FLAG="B",($G(VALUE)'="") D EXMTCH
+38 QUIT
EXMTCH ;Look for exact match
+1 IF $DATA(^DIC(42,"B",VALUE))
Begin DoDot:1
+2 NEW IEN
+3 SET IEN=0
+4 FOR
SET IEN=$ORDER(^DIC(42,"B",VALUE,IEN))
if IEN=""
QUIT
Begin DoDot:2
+5 NEW NAME
+6 SET NAME=$PIECE($GET(^DIC(42,+IEN,0)),U)
+7 ; S CNT=CNT+1
+8 IF MAXNUM'=""
SET MAXNUM=MAXNUM-1
+9 IF FLAG'="B"
SET CNT=CNT+1
DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
+10 IF FLAG="B"
SET BACKMTCH=IEN_U_NAME
End DoDot:2
End DoDot:1
+11 QUIT
+12 ; -- get list of providers for patient lookup by provider
+13 ; from ORQPTQ2
PLIST(ITEM,VALUE,MAXNUM) ;
+1 NEW NAME,IEN,DGRRB,FLAG,CNT2,DGRRSCR,DGRRFMT
+2 SET VALUE=$$UP^XLFSTR($GET(VALUE))
+3 SET NAME=$GET(VALUE)
+4 SET MAXNUM=$GET(MAXNUM)
+5 SET DGRRB=1
+6 ;K ^TMP("DGRRLU3-PLIST",$J)
+7 KILL ^TMP("DILIST",$JOB)
+8 IF $EXTRACT(MAXNUM)="-"
Begin DoDot:1
+9 ; *****
SET DGRRB=-1
+10 ; *****
IF MAXNUM="-"
SET MAXNUM=""
QUIT
+11 SET MAXNUM=$$ABS^XLFMTH(MAXNUM)
End DoDot:1
+12 SET (FLAG,CNT)=0
+13 ;I $L(NAME)>0,DGRRB=1,$D(^VA(200,"B",NAME)) S NAME=$O(^VA(200,"B",NAME),-1)
+14 ;I $L(NAME)>0,DGRRB=-1,$D(^VA(200,"B",NAME)) S NAME=$O(^VA(200,"B",NAME))
+15 ;FOR S NAME=$O(^VA(200,"B",NAME),DGRRB) Q:NAME="" DO Q:FLAG=1
+16 ;. S IEN=0
+17 ;. FOR S IEN=$O(^VA(200,"B",NAME,IEN)) Q:IEN<1 DO Q:FLAG=1
+18 ;.. I $D(^XUSEC("PROVIDER",IEN)),$$ACTIVE^XUSER(IEN) DO
+19 ;... SET CNT=CNT+1
+20 ;... S ^TMP("DGRRLU3-PLIST",$J,CNT)=IEN_U_NAME
+21 ;... I MAXNUM,CNT>(MAXNUM-1) S FLAG=1
+22 ;S CNT2="",CNT=0
+23 ;F S CNT2=$O(^TMP("DGRRLU3-PLIST",$J,CNT2),DGRRB) Q:CNT2="" D
+24 ;. S IEN=+^TMP("DGRRLU3-PLIST",$J,CNT2)
+25 ;. S NAME=$P(^TMP("DGRRLU3-PLIST",$J,CNT2),U,2)
+26 ;. S CNT=CNT+1
+27 ;. DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
+28 IF $LENGTH(NAME)>0
IF DGRRB=1
IF $DATA(^VA(200,"AK.PROVIDER",NAME))
SET NAME=$ORDER(^VA(200,"AK.PROVIDER",NAME),-1)
+29 IF $LENGTH(NAME)>0
IF DGRRB=-1
IF $DATA(^VA(200,"AK.PROVIDER",NAME))
SET NAME=$ORDER(^VA(200,"AK.PROVIDER",NAME))
+30 SET DGRRSCR="I $$ACTIVE^XUSER(+Y)"
+31 SET DGRRFMT="P"_$SELECT(DGRRB=-1:"B",1:"")
+32 DO LIST^DIC(200,,"@;.01",DGRRFMT,MAXNUM,NAME,,"AK.PROVIDER",DGRRSCR)
+33 SET (CNT2,CNT)=0
+34 FOR
SET CNT2=$ORDER(^TMP("DILIST",$JOB,CNT2))
if CNT2=""
QUIT
Begin DoDot:1
+35 SET IEN=+$GET(^TMP("DILIST",$JOB,CNT2,0))
+36 SET NAME=$PIECE($GET(^TMP("DILIST",$JOB,CNT2,0)),U,2)
+37 SET CNT=CNT+1
+38 DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
End DoDot:1
+39 KILL ^TMP("DILIST",$JOB)
+40 DO CLEAN^DILF
+41 QUIT
+42 ;
SLIST(ITEM,VALUE,MAXNUM) ;Returns active specialties in Facility TreatingSpecialty (#45.7) file
+1 ;
+2 NEW NAME,IEN,CNT,FLAG,DGRRB,DGRRD,CNT2
+3 SET NAME=$$UP^XLFSTR($GET(VALUE))
+4 ; S NAME=$G(VALUE)
+5 SET (FLAG,IEN,CNT)=0
+6 SET MAXNUM=$GET(MAXNUM)
+7 SET DGRRB=1
+8 KILL ^TMP("DGRRLU3-SLIST",$JOB)
+9 IF $EXTRACT(MAXNUM)="-"
Begin DoDot:1
+10 SET DGRRB=-1
+11 SET MAXNUM=$$ABS^XLFMTH(MAXNUM)
End DoDot:1
+12 ;Capture exact matches
+13 IF $LENGTH(NAME)
IF $DATA(^DIC(45.7,"B",NAME))
Begin DoDot:1
+14 NEW DGRRD
+15 SET DGRRD=$SELECT(DGRRB=1:-1,1:1)
+16 SET NAME=$ORDER(^DIC(45.7,"B",NAME),DGRRD)
End DoDot:1
+17 FOR
SET NAME=$ORDER(^DIC(45.7,"B",NAME),DGRRB)
if NAME=""
QUIT
Begin DoDot:1
+18 FOR
SET IEN=$ORDER(^DIC(45.7,"B",NAME,IEN))
if IEN'>0
QUIT
Begin DoDot:2
+19 IF $$ACTIVE^DGACT(45.7,IEN)
Begin DoDot:3
+20 SET CNT=CNT+1
+21 IF MAXNUM
IF (CNT>MAXNUM)
SET FLAG=1
QUIT
+22 ; DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
+23 SET ^TMP("DGRRLU3-SLIST",$JOB,CNT)=IEN_U_NAME
End DoDot:3
End DoDot:2
if FLAG=1
QUIT
End DoDot:1
if FLAG=1
QUIT
+24 SET CNT=1
SET CNT2=""
+25 SET DGRRD=$SELECT(DGRRB=1:1,1:-1)
+26 FOR
SET CNT2=$ORDER(^TMP("DGRRLU3-SLIST",$JOB,CNT2),DGRRD)
if CNT2=""
QUIT
Begin DoDot:1
+27 SET IEN=+^TMP("DGRRLU3-SLIST",$JOB,CNT2)
+28 SET NAME=$PIECE(^TMP("DGRRLU3-SLIST",$JOB,CNT2),U,2)
+29 DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
+30 SET CNT=CNT+1
End DoDot:1
+31 QUIT
+32 ;
DISPLAY(RESULT) ;
+1 NEW I
+2 SET I=-1
FOR
SET I=$ORDER(@RESULT@(I))
if I<1
QUIT
WRITE !!,@RESULT@(I)
+3 QUIT
