- DGRRLU3 ;alb/aas - DG Replacement and Rehosting RPC for VADPT ;8/8/05 15:38
- ;;5.3;Registration;**538,1015**;Aug 13, 1993;Build 21
- ;
- 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
- DGRRLU3 ;alb/aas - DG Replacement and Rehosting RPC for VADPT ;8/8/05 15:38
- +1 ;;5.3;Registration;**538,1015**;Aug 13, 1993;Build 21
- +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