ADGSRVL ; IHS/ADC/PDW/ENM - PRINT PATIENTS BY SERVICE ; [ 03/25/1999 11:48 AM ]
;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
;
W @IOF,!!!!?25,"Print Patient List by Treating Specialty",!!
;
;***> choose all services or just one
ALL K DIR S DIR(0)="YO",DIR("B")="NO"
S DIR("A")="Print for ALL Treating Specialties?" D ^DIR
G:$D(DIRUT) END I Y=1 S DGZSRT="A" G DEV
;
SRV K DIR S DIR(0)="PO^45.7:EMQZ",DIR("A")="Select Treating Specialty"
D ^DIR G END:$D(DTOUT),ALL:$D(DUOUT),END:$D(DIROUT),SRV:Y=-1
S DGZSRT=+Y
;
;***> get print device
DEV S %ZIS="PQ" D ^%ZIS G END:POP,QUE:$D(IO("Q")) U IO G START
QUE K IO("Q") S ZTRTN="START^ADGSRVL",ZTDESC="PRINT PATIENT LIST"
S ZTSAVE("DGZSRT")="" D ^%ZTLOAD D ^%ZISC K ZTSK
END K Y,DGZSRT,DIR D HOME^%ZIS Q
;
;
START ;***> initialize variables
S DGTY="INPATIENT LIST BY SERVICE"
S (DGLIN,DGLIN2)="",$P(DGLIN,"=",80)="",$P(DGLIN2,"-",80)=""
S DGDUZ=$P(^VA(200,DUZ,0),U,2),DGFAC=$P(^DIC(4,DUZ(2),0),U)
S DGPAGE=0 D HEAD
S DGSTOP="" S DGSV=$S(DGZSRT="A":0,1:DGZSRT) G FIND1:DGSV>0
;
;***> get services, then all patients in each service
FIND S DGSV=$O(^DPT("ATR",DGSV)) G END1:DGSV=""
FIND1 S DFN=0 W !,$P(^DIC(45.7,DGSV,0),U) ;print service name
I $Y>(IOSL-5) D NEWPG G END2:DGSTOP=U
FIND2 S DFN=$O(^DPT("ATR",DGSV,DFN)) W "." G PRINT:DFN=""
G FIND2:'$D(^DPT(DFN,.103)),FIND2:'$D(^DPT(DFN,0))
S DGCHT=$S($D(^AUPNPAT(DFN,41,DUZ(2),0)):$P(^(0),U,2),1:"??") ;chart#
S:+DGCHT DGX=6-$L(DGCHT) F DGI=1:1:DGX S DGCHT="0"_DGCHT
S DGCHT=$E(DGCHT,1,2)_"-"_$E(DGCHT,3,4)_"-"_$E(DGCHT,5,6)
S DGNM=$P(^DPT(DFN,0),U),DGA(DGNM,DFN)=DGCHT G FIND2 ;set DGA array
;
;***> print all patients for this srv, then get another or go to end
PRINT I '$D(DGA) W !!?10,"*** NO PATIENTS CURRENTLY ADMITTED TO THIS SERVICE ***",!! G END1
S DGNM=0 D WRITE K DGA G END2:DGSTOP=U,FIND:DGZSRT="A",END1
;
;***> print patient info
WRITE S DGNM=$O(DGA(DGNM)) Q:DGNM="" S DFN=0
W1 S DFN=$O(DGA(DGNM,DFN)) G WRITE:DFN="" S DGX=DGA(DGNM,DFN)
W !?20,$E(DGNM,1,25),?50,DGX ;patient name & chart #
W ?60,$E($G(^DPT(DFN,.1)),1,3) ;ward
W ?70,$G(^DPT(DFN,.101)) ;room-bed
I $Y>(IOSL-5) D NEWPG Q:DGSTOP=U
G W1
;
;
END1 ;***> eoj
I IOST["C-" D PRTOPT^ADGVAR
END2 D ^%ZISC I $D(ZTQUEUED) Q
K DFN,DGSTOP,DGNM,DGA,DGSV,DGPAGE,DGTIME,DGCITY,DGTY,DGX,DGCHT,DGZSRT
K DGDUZ,DGFAC,DGLIN,DGLIN2,DIR
Q
;
NEWPG ;***> subrtn for end of page control
I IOST'?1"C-".E D HEAD S DGSTOP="" Q
K DIR S DIR(0)="E" D ^DIR S DGSTOP=X
I DGSTOP'=U D HEAD
Q
;
HEAD ;***> subrtn to print heading
I (IOST["C-")!(DGPAGE>0) W @IOF
S DGPAGE=DGPAGE+1
W ?11,"*****Confidential Patient Data Covered by Privacy Act*****"
W !?80-$L(DGFAC)/2,DGFAC,!,DGDUZ
W ?80-$L(DGTY)/2,DGTY,?70,"Page: ",DGPAGE,! D ^%T
S Y=DT X ^DD("DD") W ?80-$L(Y)/2,Y,!,DGLIN
W !,"Service",?20,"Patient",?50,"Chart #"
W ?60,"Ward",?70,"Room-Bed",!,DGLIN2,!
Q
ADGSRVL ; IHS/ADC/PDW/ENM - PRINT PATIENTS BY SERVICE ; [ 03/25/1999 11:48 AM ]
+1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
+2 ;
+3 WRITE @IOF,!!!!?25,"Print Patient List by Treating Specialty",!!
+4 ;
+5 ;***> choose all services or just one
ALL KILL DIR
SET DIR(0)="YO"
SET DIR("B")="NO"
+1 SET DIR("A")="Print for ALL Treating Specialties?"
DO ^DIR
+2 IF $DATA(DIRUT)
GOTO END
IF Y=1
SET DGZSRT="A"
GOTO DEV
+3 ;
SRV KILL DIR
SET DIR(0)="PO^45.7:EMQZ"
SET DIR("A")="Select Treating Specialty"
+1 DO ^DIR
IF $DATA(DTOUT)
GOTO END
IF $DATA(DUOUT)
GOTO ALL
IF $DATA(DIROUT)
GOTO END
IF Y=-1
GOTO SRV
+2 SET DGZSRT=+Y
+3 ;
+4 ;***> get print device
DEV SET %ZIS="PQ"
DO ^%ZIS
IF POP
GOTO END
IF $DATA(IO("Q"))
GOTO QUE
USE IO
GOTO START
QUE KILL IO("Q")
SET ZTRTN="START^ADGSRVL"
SET ZTDESC="PRINT PATIENT LIST"
+1 SET ZTSAVE("DGZSRT")=""
DO ^%ZTLOAD
DO ^%ZISC
KILL ZTSK
END KILL Y,DGZSRT,DIR
DO HOME^%ZIS
QUIT
+1 ;
+2 ;
START ;***> initialize variables
+1 SET DGTY="INPATIENT LIST BY SERVICE"
+2 SET (DGLIN,DGLIN2)=""
SET $PIECE(DGLIN,"=",80)=""
SET $PIECE(DGLIN2,"-",80)=""
+3 SET DGDUZ=$PIECE(^VA(200,DUZ,0),U,2)
SET DGFAC=$PIECE(^DIC(4,DUZ(2),0),U)
+4 SET DGPAGE=0
DO HEAD
+5 SET DGSTOP=""
SET DGSV=$SELECT(DGZSRT="A":0,1:DGZSRT)
IF DGSV>0
GOTO FIND1
+6 ;
+7 ;***> get services, then all patients in each service
FIND SET DGSV=$ORDER(^DPT("ATR",DGSV))
IF DGSV=""
GOTO END1
FIND1 ;print service name
SET DFN=0
WRITE !,$PIECE(^DIC(45.7,DGSV,0),U)
+1 IF $Y>(IOSL-5)
DO NEWPG
IF DGSTOP=U
GOTO END2
FIND2 SET DFN=$ORDER(^DPT("ATR",DGSV,DFN))
WRITE "."
IF DFN=""
GOTO PRINT
+1 IF '$DATA(^DPT(DFN,.103))
GOTO FIND2
IF '$DATA(^DPT(DFN,0))
GOTO FIND2
+2 ;chart#
SET DGCHT=$SELECT($DATA(^AUPNPAT(DFN,41,DUZ(2),0)):$PIECE(^(0),U,2),1:"??")
+3 IF +DGCHT
SET DGX=6-$LENGTH(DGCHT)
FOR DGI=1:1:DGX
SET DGCHT="0"_DGCHT
+4 SET DGCHT=$EXTRACT(DGCHT,1,2)_"-"_$EXTRACT(DGCHT,3,4)_"-"_$EXTRACT(DGCHT,5,6)
+5 ;set DGA array
SET DGNM=$PIECE(^DPT(DFN,0),U)
SET DGA(DGNM,DFN)=DGCHT
GOTO FIND2
+6 ;
+7 ;***> print all patients for this srv, then get another or go to end
PRINT IF '$DATA(DGA)
WRITE !!?10,"*** NO PATIENTS CURRENTLY ADMITTED TO THIS SERVICE ***",!!
GOTO END1
+1 SET DGNM=0
DO WRITE
KILL DGA
IF DGSTOP=U
GOTO END2
IF DGZSRT="A"
GOTO FIND
GOTO END1
+2 ;
+3 ;***> print patient info
WRITE SET DGNM=$ORDER(DGA(DGNM))
IF DGNM=""
QUIT
SET DFN=0
W1 SET DFN=$ORDER(DGA(DGNM,DFN))
IF DFN=""
GOTO WRITE
SET DGX=DGA(DGNM,DFN)
+1 ;patient name & chart #
WRITE !?20,$EXTRACT(DGNM,1,25),?50,DGX
+2 ;ward
WRITE ?60,$EXTRACT($GET(^DPT(DFN,.1)),1,3)
+3 ;room-bed
WRITE ?70,$GET(^DPT(DFN,.101))
+4 IF $Y>(IOSL-5)
DO NEWPG
IF DGSTOP=U
QUIT
+5 GOTO W1
+6 ;
+7 ;
END1 ;***> eoj
+1 IF IOST["C-"
DO PRTOPT^ADGVAR
END2 DO ^%ZISC
IF $DATA(ZTQUEUED)
QUIT
+1 KILL DFN,DGSTOP,DGNM,DGA,DGSV,DGPAGE,DGTIME,DGCITY,DGTY,DGX,DGCHT,DGZSRT
+2 KILL DGDUZ,DGFAC,DGLIN,DGLIN2,DIR
+3 QUIT
+4 ;
NEWPG ;***> subrtn for end of page control
+1 IF IOST'?1"C-".E
DO HEAD
SET DGSTOP=""
QUIT
+2 KILL DIR
SET DIR(0)="E"
DO ^DIR
SET DGSTOP=X
+3 IF DGSTOP'=U
DO HEAD
+4 QUIT
+5 ;
HEAD ;***> subrtn to print heading
+1 IF (IOST["C-")!(DGPAGE>0)
WRITE @IOF
+2 SET DGPAGE=DGPAGE+1
+3 WRITE ?11,"*****Confidential Patient Data Covered by Privacy Act*****"
+4 WRITE !?80-$LENGTH(DGFAC)/2,DGFAC,!,DGDUZ
+5 WRITE ?80-$LENGTH(DGTY)/2,DGTY,?70,"Page: ",DGPAGE,!
DO ^%T
+6 SET Y=DT
XECUTE ^DD("DD")
WRITE ?80-$LENGTH(Y)/2,Y,!,DGLIN
+7 WRITE !,"Service",?20,"Patient",?50,"Chart #"
+8 WRITE ?60,"Ward",?70,"Room-Bed",!,DGLIN2,!
+9 QUIT
