DGQPTQ2 ; slc/CLA - Functions which return patient lists and list sources pt 2 ;05/05/2004
;;5.3;Registration;**447,598,725**;Aug 13, 1993;Build 12
CLIN(Y) ; RETURN LIST OF CLINICS
N DGLST,IEN,I
D GETLST^XPAR(.DGLST,"ALL","DGWD COMMON CLINIC")
S I=0 F S I=$O(DGLST(I)) Q:'I D
. S IEN=$P(DGLST(I),U,2) I $$ACTLOC^SDWU(IEN)=1 D
.. S Y(I)=IEN_U_$P(^SC(IEN,0),U,1)
Q
CLINPTS(Y,CLIN,DGBDATE,DGEDATE) ; RETURN LIST OF PTS W/CLINIC APPT W/IN BEGINNING AND END DATES
I +$G(CLIN)<1 S Y(1)="^No clinic identified" Q
I $$ACTLOC^SDWU(CLIN)'=1 S Y(1)="^Clinic is inactive or Occasion Of Service" Q
N DFN,NAME,I,J,X,DGJ,DGSRV,DGNOWDT,CHKX,CHKIN,MAXAPPTS,DGC,CLNAM
S MAXAPPTS=200
S DGNOWDT=$$NOW^XLFDT
S DGSRV=$G(^VA(200,DUZ,5)) I +DGSRV>0 S DGSRV=$P(DGSRV,U)
S DFN=0,I=1
I DGBDATE="" S DGBDATE=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_+$G(DGSRV)_"^DIV^SYS^PKG","DGLP DEFAULT CLINIC START DATE",1,"E"))
I DGEDATE="" S DGEDATE=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_+$G(DGSRV)_"^DIV^SYS^PKG","DGLP DEFAULT CLINIC STOP DATE",1,"E"))
;CONVERT DGBDATE AND DGEDATE INTO FILEMAN DATE/TIME
D DT^DILF("T",DGBDATE,.DGBDATE,"","")
D DT^DILF("T",DGEDATE,.DGEDATE,"","")
I (DGBDATE=-1)!(DGEDATE=-1) S Y(1)="^Error in date range." Q
S DGEDATE=$P(DGEDATE,".")_.5
;
N DGARRAY,SDCNT,SDFN,SAPPT,ASTAT
S DGARRAY(1)=DGBDATE_";"_DGEDATE,DGARRAY(2)=CLIN,DGARRAY("FLDS")="1;2;3"
S DGARRAY("SORT")="P",SDCNT=$$SDAPI^SDAMA301(.DGARRAY)
I SDCNT<0 S X=$$FAPCHK^DGENRPD2 I X'="" S Y(1)=X K ^TMP($J,"SDAMA301") Q
S SDFN=0 F S SDFN=$O(^TMP($J,"SDAMA301",SDFN)) Q:'SDFN D
.S SAPPT=0 F S SAPPT=$O(^TMP($J,"SDAMA301",SDFN,SAPPT)) Q:'SAPPT D
..S ^TMP($J,"SDAM",SAPPT,SDFN)=SDFN_"^"_^TMP($J,"SDAMA301",SDFN,SAPPT)
;
S DGJ=0 F S DGJ=$O(^TMP($J,"SDAM",DGJ)) Q:'DGJ D
.S DFN=0 F S DFN=$O(^TMP($J,"SDAM",DGJ,DFN)) Q:'DFN D
..S ASTAT=$P($P(^TMP($J,"SDAM",DGJ,DFN),"^",4),";")
..; quit if appt cancelled or no show:
..I ASTAT'="NT",(ASTAT["C")!(ASTAT["N") Q
..S Y(I)=DFN_"^"_$P(^DPT(DFN,0),"^")_"^"_+CLIN_"^"_DGJ,I=I+1
;
I I>MAXAPPTS D ;maximum allowable appointments exceeded
.S CLNAM=$P($G(^SC(CLIN,0)),U)
.K Y S Y(1)="^CLINIC: "_CLNAM_" - Too many appointments found; please narrow search range."
S:'$D(Y) Y(1)="^No appointments."
K ^TMP($J,"SDAM"),^TMP($J,"SDAMA301"),SDCNT,DGARRAY,SDFN,SAPPT,ASTAT
Q
CDATRANG(DGY) ; return default start and stop dates for clinics in form start^stop
N DGBDATE,DGEDATE,DGSRV
S DGSRV=$G(^VA(200,DUZ,5)) I +DGSRV>0 S DGSRV=$P(DGSRV,U)
S DGBDATE=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_+$G(DGSRV)_"^DIV^SYS^PKG","DGLP DEFAULT CLINIC START DATE",1,"E"))
S DGEDATE=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_+$G(DGSRV)_"^DIV^SYS^PKG","DGLP DEFAULT CLINIC STOP DATE",1,"E"))
S DGBDATE=$S($L($G(DGBDATE)):DGBDATE,1:""),DGEDATE=$S($L($G(DGEDATE)):DGEDATE,1:"")
S DGY=$$UP^XLFSTR(DGBDATE)_"^"_$$UP^XLFSTR(DGEDATE)
Q
PTAPPTS(Y,DFN,DGBDATE,DGEDATE,CLIN) ; return appts for a patient between beginning and end dates for a clinic, if no clinic return all appointments
;I +$G(CLIN)<1 S Y(1)="^No clinic identified" Q
I +$G(CLIN)>0,$$ACTLOC^SDWU(CLIN)'=1 S Y(1)="^Clinic is inactive or Occasion Of Service" Q
N VASD,NUM,CNT,INVDT,INT,EXT,DGSRV S NUM=0,CNT=1
I (DGBDATE="")!(DGEDATE="") D ;get user's service and set up entities:
.S DGSRV=$G(^VA(200,DUZ,5)) I +DGSRV>0 S DGSRV=$P(DGSRV,U)
I DGBDATE="" D
.I '$L(CLIN) S DGBDATE=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_+$G(DGSRV)_"^DIV^SYS^PKG","DGQQAP SEARCH RANGE START",1,"E"))
.S:DGBDATE="" DGBDATE="T" ;default start date across all clinics is today
I DGEDATE="" D
.I '$L(CLIN) S DGEDATE=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_+$G(DGSRV)_"^DIV^SYS^PKG","DGQQAP SEARCH RANGE STOP",1,"E"))
.S:DGEDATE="" DGEDATE="T" ;default end date across all clinics is today
;CONVERT DGBDATE AND DGEDATE INTO FILEMAN DATE/TIME
D DT^DILF("T",DGBDATE,.DGBDATE,"","")
D DT^DILF("T",DGEDATE,.DGEDATE,"","")
I (DGBDATE=-1)!(DGEDATE=-1) S Y(1)="^Error in date range." Q
S VASD("F")=DGBDATE
S VASD("T")=$P(DGEDATE,".")_.5 ;ADD 1/2 DAY TO END DATE
I $L($G(CLIN)) S VASD("C",CLIN)=""
D SDA^VADPT
Q:VAERR=1
F S NUM=$O(^UTILITY("VASD",$J,NUM)) Q:'NUM D
.S INT=^UTILITY("VASD",$J,NUM,"I"),INVDT=9999999-$P(INT,U)
.S EXT=^UTILITY("VASD",$J,NUM,"E")
.S Y(CNT)=$P(INT,U)_U_$P(EXT,U,2)_U_$P(EXT,U,3)_U_$P(EXT,U,4)_U_INVDT
.S CNT=CNT+1
S:+$G(Y(1))<1 Y(1)="^No appointments."
K VAERR
Q
PROV(Y) ; RETURN LIST OF PROVIDERS
N I,IEN,NAME,TDATE
S I=1,NAME=""
F S NAME=$O(^VA(200,"B",NAME)) Q:NAME="" S IEN=0,IEN=$O(^(NAME,IEN)) D
.Q:$E(NAME)="*"
.I $D(^XUSEC("PROVIDER",IEN)),$$ACTIVE^XUSER(IEN) S Y(I)=IEN_"^"_NAME,I=I+1
Q
PROVPTS(Y,PROV) ; RETURN LIST OF PATIENTS LINKED TO A PRIMARY PROVIDER
I +$G(PROV)<1 S Y(1)="^No provider identified" Q
N DGI,DFN
S DGI=1,DFN=0
F S DFN=$O(^DPT("APR",PROV,DFN)) Q:DFN'>0 S Y(DGI)=+DFN_"^"_$P(^DPT(+DFN,0),"^"),DGI=DGI+1
S:+$G(Y(1))<1 Y(1)="^No patients found."
Q
SPEC(Y) ; RETURN LIST OF TREATING SPECIALTIES
N I,NAME,IEN
S I=1,NAME=""
;access to DIC(45.7 global granted under DBIA #519:
F S NAME=$O(^DIC(45.7,"B",NAME)) Q:NAME="" S IEN=0,IEN=$O(^(NAME,IEN)) I $$ACTIVE^DGACT(45.7,IEN) S Y(I)=IEN_"^"_NAME,I=I+1
Q
SPECPTS(Y,SPEC) ; RETURN LIST OF PATIENTS LINKED TO A TREATING SPECIALTY
I +$G(SPEC)<1 S Y(1)="^No specialty identified" Q
N DGI,DFN
S DGI=1,DFN=0
F S DFN=$O(^DPT("ATR",SPEC,DFN)) Q:DFN'>0 S Y(DGI)=+DFN_"^"_$P(^DPT(+DFN,0),"^"),DGI=DGI+1
S:+$G(Y(1))<1 Y(1)="^No patients found."
Q
WARD(Y) ; RETURN LIST OF ACTIVE WARDS
N I,IEN,NAME,D0
S I=1,NAME=""
;access to DIC(42 global granted under DBIA #36:
F S NAME=$O(^DIC(42,"B",NAME)) Q:NAME="" S IEN=$O(^(NAME,0)) D
. S D0=IEN D WIN^DGPMDDCF
. I X=0 S Y(I)=IEN_"^"_NAME,I=I+1
Q
WARDPTS(Y,WARD) ; RETURN LIST OF PATIENTS IN A WARD
; SLC/PKS - Modifications for Room/Bed data on 1/19/2001.
I +$G(WARD)<1 S Y(1)="^No ward identified" Q
N DGI,DFN,RBDAT
S DGI=1,DFN=0
;access to DIC(42 global granted under DBIA #36:
S WARD=$P(^DIC(42,WARD,0),"^") ;GET WARD NAME FOR "CN" LOOKUP
; Next section modified 1/19/2001 by PKS:
F D Q:DFN'>0
.S DFN=$O(^DPT("CN",WARD,DFN)) Q:DFN'>0
.S Y(DGI)=+DFN_"^"_$P(^DPT(+DFN,0),"^")
.S RBDAT=""
.; Add patient room/bed information where data exists:
.S RBDAT=$P($G(^DPT(+DFN,.101)),U)
.; Assure at least 4 letters for any existing room/bed data:
.I RBDAT'="" D ; Any R/B data?
..I $L(RBDAT)<4 D ; Less than 4 now?
...S RBDAT=RBDAT_" " ; Add 3 for safety.
...S RBDAT=$E(RBDAT,1,4) ; Get first 4 only.
...S Y(DGI)=Y(DGI)_U_RBDAT ; Add R/B to string
.S DGI=DGI+1 ; Increment counter.
;
S:+$G(Y(1))<1 Y(1)="^No patients found."
Q
NLIST(DGQY) ; return a null list
S DGQY(1)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGQPTQ2 6937 printed Apr 09, 2024@21:50:43 Page 2
DGQPTQ2 ; slc/CLA - Functions which return patient lists and list sources pt 2 ;05/05/2004
+1 ;;5.3;Registration;**447,598,725**;Aug 13, 1993;Build 12
CLIN(Y) ; RETURN LIST OF CLINICS
+1 NEW DGLST,IEN,I
+2 DO GETLST^XPAR(.DGLST,"ALL","DGWD COMMON CLINIC")
+3 SET I=0
FOR
SET I=$ORDER(DGLST(I))
if 'I
QUIT
Begin DoDot:1
+4 SET IEN=$PIECE(DGLST(I),U,2)
IF $$ACTLOC^SDWU(IEN)=1
Begin DoDot:2
+5 SET Y(I)=IEN_U_$PIECE(^SC(IEN,0),U,1)
End DoDot:2
End DoDot:1
+6 QUIT
CLINPTS(Y,CLIN,DGBDATE,DGEDATE) ; RETURN LIST OF PTS W/CLINIC APPT W/IN BEGINNING AND END DATES
+1 IF +$GET(CLIN)<1
SET Y(1)="^No clinic identified"
QUIT
+2 IF $$ACTLOC^SDWU(CLIN)'=1
SET Y(1)="^Clinic is inactive or Occasion Of Service"
QUIT
+3 NEW DFN,NAME,I,J,X,DGJ,DGSRV,DGNOWDT,CHKX,CHKIN,MAXAPPTS,DGC,CLNAM
+4 SET MAXAPPTS=200
+5 SET DGNOWDT=$$NOW^XLFDT
+6 SET DGSRV=$GET(^VA(200,DUZ,5))
IF +DGSRV>0
SET DGSRV=$PIECE(DGSRV,U)
+7 SET DFN=0
SET I=1
+8 IF DGBDATE=""
SET DGBDATE=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_+$GET(DGSRV)_"^DIV^SYS^PKG","DGLP DEFAULT CLINIC START DATE",1,"E"))
+9 IF DGEDATE=""
SET DGEDATE=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_+$GET(DGSRV)_"^DIV^SYS^PKG","DGLP DEFAULT CLINIC STOP DATE",1,"E"))
+10 ;CONVERT DGBDATE AND DGEDATE INTO FILEMAN DATE/TIME
+11 DO DT^DILF("T",DGBDATE,.DGBDATE,"","")
+12 DO DT^DILF("T",DGEDATE,.DGEDATE,"","")
+13 IF (DGBDATE=-1)!(DGEDATE=-1)
SET Y(1)="^Error in date range."
QUIT
+14 SET DGEDATE=$PIECE(DGEDATE,".")_.5
+15 ;
+16 NEW DGARRAY,SDCNT,SDFN,SAPPT,ASTAT
+17 SET DGARRAY(1)=DGBDATE_";"_DGEDATE
SET DGARRAY(2)=CLIN
SET DGARRAY("FLDS")="1;2;3"
+18 SET DGARRAY("SORT")="P"
SET SDCNT=$$SDAPI^SDAMA301(.DGARRAY)
+19 IF SDCNT<0
SET X=$$FAPCHK^DGENRPD2
IF X'=""
SET Y(1)=X
KILL ^TMP($JOB,"SDAMA301")
QUIT
+20 SET SDFN=0
FOR
SET SDFN=$ORDER(^TMP($JOB,"SDAMA301",SDFN))
if 'SDFN
QUIT
Begin DoDot:1
+21 SET SAPPT=0
FOR
SET SAPPT=$ORDER(^TMP($JOB,"SDAMA301",SDFN,SAPPT))
if 'SAPPT
QUIT
Begin DoDot:2
+22 SET ^TMP($JOB,"SDAM",SAPPT,SDFN)=SDFN_"^"_^TMP($JOB,"SDAMA301",SDFN,SAPPT)
End DoDot:2
End DoDot:1
+23 ;
+24 SET DGJ=0
FOR
SET DGJ=$ORDER(^TMP($JOB,"SDAM",DGJ))
if 'DGJ
QUIT
Begin DoDot:1
+25 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,"SDAM",DGJ,DFN))
if 'DFN
QUIT
Begin DoDot:2
+26 SET ASTAT=$PIECE($PIECE(^TMP($JOB,"SDAM",DGJ,DFN),"^",4),";")
+27 ; quit if appt cancelled or no show:
+28 IF ASTAT'="NT"
IF (ASTAT["C")!(ASTAT["N")
QUIT
+29 SET Y(I)=DFN_"^"_$PIECE(^DPT(DFN,0),"^")_"^"_+CLIN_"^"_DGJ
SET I=I+1
End DoDot:2
End DoDot:1
+30 ;
+31 ;maximum allowable appointments exceeded
IF I>MAXAPPTS
Begin DoDot:1
+32 SET CLNAM=$PIECE($GET(^SC(CLIN,0)),U)
+33 KILL Y
SET Y(1)="^CLINIC: "_CLNAM_" - Too many appointments found; please narrow search range."
End DoDot:1
+34 if '$DATA(Y)
SET Y(1)="^No appointments."
+35 KILL ^TMP($JOB,"SDAM"),^TMP($JOB,"SDAMA301"),SDCNT,DGARRAY,SDFN,SAPPT,ASTAT
+36 QUIT
CDATRANG(DGY) ; return default start and stop dates for clinics in form start^stop
+1 NEW DGBDATE,DGEDATE,DGSRV
+2 SET DGSRV=$GET(^VA(200,DUZ,5))
IF +DGSRV>0
SET DGSRV=$PIECE(DGSRV,U)
+3 SET DGBDATE=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_+$GET(DGSRV)_"^DIV^SYS^PKG","DGLP DEFAULT CLINIC START DATE",1,"E"))
+4 SET DGEDATE=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_+$GET(DGSRV)_"^DIV^SYS^PKG","DGLP DEFAULT CLINIC STOP DATE",1,"E"))
+5 SET DGBDATE=$SELECT($LENGTH($GET(DGBDATE)):DGBDATE,1:"")
SET DGEDATE=$SELECT($LENGTH($GET(DGEDATE)):DGEDATE,1:"")
+6 SET DGY=$$UP^XLFSTR(DGBDATE)_"^"_$$UP^XLFSTR(DGEDATE)
+7 QUIT
PTAPPTS(Y,DFN,DGBDATE,DGEDATE,CLIN) ; return appts for a patient between beginning and end dates for a clinic, if no clinic return all appointments
+1 ;I +$G(CLIN)<1 S Y(1)="^No clinic identified" Q
+2 IF +$GET(CLIN)>0
IF $$ACTLOC^SDWU(CLIN)'=1
SET Y(1)="^Clinic is inactive or Occasion Of Service"
QUIT
+3 NEW VASD,NUM,CNT,INVDT,INT,EXT,DGSRV
SET NUM=0
SET CNT=1
+4 ;get user's service and set up entities:
IF (DGBDATE="")!(DGEDATE="")
Begin DoDot:1
+5 SET DGSRV=$GET(^VA(200,DUZ,5))
IF +DGSRV>0
SET DGSRV=$PIECE(DGSRV,U)
End DoDot:1
+6 IF DGBDATE=""
Begin DoDot:1
+7 IF '$LENGTH(CLIN)
SET DGBDATE=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_+$GET(DGSRV)_"^DIV^SYS^PKG","DGQQAP SEARCH RANGE START",1,"E"))
+8 ;default start date across all clinics is today
if DGBDATE=""
SET DGBDATE="T"
End DoDot:1
+9 IF DGEDATE=""
Begin DoDot:1
+10 IF '$LENGTH(CLIN)
SET DGEDATE=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_+$GET(DGSRV)_"^DIV^SYS^PKG","DGQQAP SEARCH RANGE STOP",1,"E"))
+11 ;default end date across all clinics is today
if DGEDATE=""
SET DGEDATE="T"
End DoDot:1
+12 ;CONVERT DGBDATE AND DGEDATE INTO FILEMAN DATE/TIME
+13 DO DT^DILF("T",DGBDATE,.DGBDATE,"","")
+14 DO DT^DILF("T",DGEDATE,.DGEDATE,"","")
+15 IF (DGBDATE=-1)!(DGEDATE=-1)
SET Y(1)="^Error in date range."
QUIT
+16 SET VASD("F")=DGBDATE
+17 ;ADD 1/2 DAY TO END DATE
SET VASD("T")=$PIECE(DGEDATE,".")_.5
+18 IF $LENGTH($GET(CLIN))
SET VASD("C",CLIN)=""
+19 DO SDA^VADPT
+20 if VAERR=1
QUIT
+21 FOR
SET NUM=$ORDER(^UTILITY("VASD",$JOB,NUM))
if 'NUM
QUIT
Begin DoDot:1
+22 SET INT=^UTILITY("VASD",$JOB,NUM,"I")
SET INVDT=9999999-$PIECE(INT,U)
+23 SET EXT=^UTILITY("VASD",$JOB,NUM,"E")
+24 SET Y(CNT)=$PIECE(INT,U)_U_$PIECE(EXT,U,2)_U_$PIECE(EXT,U,3)_U_$PIECE(EXT,U,4)_U_INVDT
+25 SET CNT=CNT+1
End DoDot:1
+26 if +$GET(Y(1))<1
SET Y(1)="^No appointments."
+27 KILL VAERR
+28 QUIT
PROV(Y) ; RETURN LIST OF PROVIDERS
+1 NEW I,IEN,NAME,TDATE
+2 SET I=1
SET NAME=""
+3 FOR
SET NAME=$ORDER(^VA(200,"B",NAME))
if NAME=""
QUIT
SET IEN=0
SET IEN=$ORDER(^(NAME,IEN))
Begin DoDot:1
+4 if $EXTRACT(NAME)="*"
QUIT
+5 IF $DATA(^XUSEC("PROVIDER",IEN))
IF $$ACTIVE^XUSER(IEN)
SET Y(I)=IEN_"^"_NAME
SET I=I+1
End DoDot:1
+6 QUIT
PROVPTS(Y,PROV) ; RETURN LIST OF PATIENTS LINKED TO A PRIMARY PROVIDER
+1 IF +$GET(PROV)<1
SET Y(1)="^No provider identified"
QUIT
+2 NEW DGI,DFN
+3 SET DGI=1
SET DFN=0
+4 FOR
SET DFN=$ORDER(^DPT("APR",PROV,DFN))
if DFN'>0
QUIT
SET Y(DGI)=+DFN_"^"_$PIECE(^DPT(+DFN,0),"^")
SET DGI=DGI+1
+5 if +$GET(Y(1))<1
SET Y(1)="^No patients found."
+6 QUIT
SPEC(Y) ; RETURN LIST OF TREATING SPECIALTIES
+1 NEW I,NAME,IEN
+2 SET I=1
SET NAME=""
+3 ;access to DIC(45.7 global granted under DBIA #519:
+4 FOR
SET NAME=$ORDER(^DIC(45.7,"B",NAME))
if NAME=""
QUIT
SET IEN=0
SET IEN=$ORDER(^(NAME,IEN))
IF $$ACTIVE^DGACT(45.7,IEN)
SET Y(I)=IEN_"^"_NAME
SET I=I+1
+5 QUIT
SPECPTS(Y,SPEC) ; RETURN LIST OF PATIENTS LINKED TO A TREATING SPECIALTY
+1 IF +$GET(SPEC)<1
SET Y(1)="^No specialty identified"
QUIT
+2 NEW DGI,DFN
+3 SET DGI=1
SET DFN=0
+4 FOR
SET DFN=$ORDER(^DPT("ATR",SPEC,DFN))
if DFN'>0
QUIT
SET Y(DGI)=+DFN_"^"_$PIECE(^DPT(+DFN,0),"^")
SET DGI=DGI+1
+5 if +$GET(Y(1))<1
SET Y(1)="^No patients found."
+6 QUIT
WARD(Y) ; RETURN LIST OF ACTIVE WARDS
+1 NEW I,IEN,NAME,D0
+2 SET I=1
SET NAME=""
+3 ;access to DIC(42 global granted under DBIA #36:
+4 FOR
SET NAME=$ORDER(^DIC(42,"B",NAME))
if NAME=""
QUIT
SET IEN=$ORDER(^(NAME,0))
Begin DoDot:1
+5 SET D0=IEN
DO WIN^DGPMDDCF
+6 IF X=0
SET Y(I)=IEN_"^"_NAME
SET I=I+1
End DoDot:1
+7 QUIT
WARDPTS(Y,WARD) ; RETURN LIST OF PATIENTS IN A WARD
+1 ; SLC/PKS - Modifications for Room/Bed data on 1/19/2001.
+2 IF +$GET(WARD)<1
SET Y(1)="^No ward identified"
QUIT
+3 NEW DGI,DFN,RBDAT
+4 SET DGI=1
SET DFN=0
+5 ;access to DIC(42 global granted under DBIA #36:
+6 ;GET WARD NAME FOR "CN" LOOKUP
SET WARD=$PIECE(^DIC(42,WARD,0),"^")
+7 ; Next section modified 1/19/2001 by PKS:
+8 FOR
Begin DoDot:1
+9 SET DFN=$ORDER(^DPT("CN",WARD,DFN))
if DFN'>0
QUIT
+10 SET Y(DGI)=+DFN_"^"_$PIECE(^DPT(+DFN,0),"^")
+11 SET RBDAT=""
+12 ; Add patient room/bed information where data exists:
+13 SET RBDAT=$PIECE($GET(^DPT(+DFN,.101)),U)
+14 ; Assure at least 4 letters for any existing room/bed data:
+15 ; Any R/B data?
IF RBDAT'=""
Begin DoDot:2
+16 ; Less than 4 now?
IF $LENGTH(RBDAT)<4
Begin DoDot:3
+17 ; Add 3 for safety.
SET RBDAT=RBDAT_" "
+18 ; Get first 4 only.
SET RBDAT=$EXTRACT(RBDAT,1,4)
+19 ; Add R/B to string
SET Y(DGI)=Y(DGI)_U_RBDAT
End DoDot:3
End DoDot:2
+20 ; Increment counter.
SET DGI=DGI+1
End DoDot:1
if DFN'>0
QUIT
+21 ;
+22 if +$GET(Y(1))<1
SET Y(1)="^No patients found."
+23 QUIT
NLIST(DGQY) ; return a null list
+1 SET DGQY(1)=""
+2 QUIT
