ADGPTLP ; IHS/ADC/PDW/ENM - PRINT PATIENT LIST BY WARD ; [ 03/25/1999 11:48 AM ]
;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
;
;***> initialize variables
U IO S DGPG=0,DGSTOP=""
S DGSITE=$P(^DIC(4,DUZ(2),0),U),DGDUZ=$P(^VA(200,DUZ,0),U,2)
S (DGLIN,DGLIN1)="",$P(DGLIN,"-",80)="",$P(DGLIN1,"=",80)=""
;
;***> loop thru wards and beds to print patient data
S DGW=0
A1 S DGW=$O(^TMP("DGZPTL",$J,"BED",DGW)) G END:DGW="" S DGR=0 D HEAD
A2 S DGR=$O(^TMP("DGZPTL",$J,"BED",DGW,DGR))
I DGR="" D ^ADGPTLP0 G END1:DGSTOP=U,A1
S DGRM=^TMP("DGZPTL",$J,"BED",DGW,DGR)
S (DFN,DGNM,DGAD,DGSER,DGDX,DGPRV,DGCOM,DGCHART,AGE,DGLOS,DGDS)=""
S DGBED=$P(DGRM,"-",2,3)
G PRNT:'$D(^TMP("DGZPTL",$J,"WD",DGRM)) S DGSTR=^(DGRM)
S DFN=$P(DGSTR,U)
S DGNM=$P(DGSTR,U,2),DGDS=$P(DGSTR,U,7),DGCOM=$P(DGSTR,U,6)
S DGAD=$P(DGSTR,U,3),DGDX=$P(DGSTR,U,4),DGPRV=$P(DGSTR,U,5)
S:DGPRV?1N.N DGPRV=$P(^VA(200,DGPRV,0),U)
S DGCHART=$P(^AUPNPAT(DFN,41,DUZ(2),0),U,2),DGXX=6-$L(DGCHART)
F DGII=1:1:DGXX S DGCHART="0"_DGCHART
K ^UTILITY("DIQ1",$J)
S DA=DFN,DIC=2,DR=.033 D EN^DIQ1
S AGE=^UTILITY("DIQ1",$J,2,DFN,.033)
K ^UTILTIY("DIQ1",$J)
I DGAD'="" S X=$P(DGAD,".",1) D H^%DTC S DGLOS=(+$H-+%H)+1
I DGO=2,DGDX]"" S DGSER=DGDX
I DGO=2,DGDX?1N.N S DGSER=$E($P(^DIC(45.7,DGDX,0),U),1,20)
;
PRNT I $Y>(IOSL-5) D NEWPG G END1:DGSTOP=U
W !,DGDS,?3,DGBED,?9,$E(DGNM,1,20)
W:DGCHART ?31,$E(DGCHART,1,2)_"-"_$E(DGCHART,3,4)_"-"_$E(DGCHART,5,6)
W ?42,AGE
I DGO=4 D G PRNT1
. I DFN S X="SRZPEP" X ^%ZOSF("TEST") I $T W ?50,$$SDA^SRZPEP(DFN)
. W !
. W:DGDX'="" ?20,"(",$E(DGDX,1,25),")"
W ?47,$J(DGLOS,2)
W ?53,$S(DGO=1:$E(DGDX,1,25),DGO=2:DGSER,1:"")
W ! W:DGPRV'="" ?11,"(",$E(DGPRV,1,15),")"
W:DGCOM'="" ?33,"(",DGCOM,")"
I DFN S X="SRZPEP" X ^%ZOSF("TEST") I $T W ?50,$$SDA^SRZPEP(DFN)
PRNT1 W !,DGLIN G A2
;
;
END ;***> eoj
I IOST?1"C-".E K DIR S DIR(0)="E" D ^DIR D ^XBCLS
END1 ;EP
;D ^%ZISC W ! **CRG 2/19/97
W ! D ^%ZISC
D KILL^ADGUTIL
K ^TMP("DGZPTL",$J) Q
;
;
NEWPG ;EP;***> 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-")!(DGPG>0) W @IOF
W !,DGLIN1 S DGPG=DGPG+1
W !?11,"*****Confidential Patient Data Covered by Privacy Act*****"
W !,DGDUZ,?80-$L(DGSITE)/2,DGSITE S DGTY="INPATIENT ROSTER"
W ! D TIME^ADGUTIL W ?80-$L(DGTY)/2,DGTY,?70,"Page: ",DGPG
S Y=DT X ^DD("DD") W !,Y
S DGWARD="*** "_$P(^DIC(42,DGW,0),U)_" ***" W ?80-$L(DGWARD)/2,DGWARD
W !,DGLIN1
W !?3,"Room",?9,"Patient",?31,"Chart #",?41,"Age"
I DGO=4 W ?55,"Nursing Notes",!?20,"(Admitting Diagnosis)" G HD1
W ?46,"LOS",?61,$S(DGO=1:"Admitting",DGO=2:"Service",1:"")
W !?11,"(Provider)",?33,"(Community)",?61 W:DGO=1 "Diagnosis"
HD1 W !,DGLIN,!
Q
ADGPTLP ; IHS/ADC/PDW/ENM - PRINT PATIENT LIST BY WARD ; [ 03/25/1999 11:48 AM ]
+1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
+2 ;
+3 ;***> initialize variables
+4 USE IO
SET DGPG=0
SET DGSTOP=""
+5 SET DGSITE=$PIECE(^DIC(4,DUZ(2),0),U)
SET DGDUZ=$PIECE(^VA(200,DUZ,0),U,2)
+6 SET (DGLIN,DGLIN1)=""
SET $PIECE(DGLIN,"-",80)=""
SET $PIECE(DGLIN1,"=",80)=""
+7 ;
+8 ;***> loop thru wards and beds to print patient data
+9 SET DGW=0
A1 SET DGW=$ORDER(^TMP("DGZPTL",$JOB,"BED",DGW))
IF DGW=""
GOTO END
SET DGR=0
DO HEAD
A2 SET DGR=$ORDER(^TMP("DGZPTL",$JOB,"BED",DGW,DGR))
+1 IF DGR=""
DO ^ADGPTLP0
IF DGSTOP=U
GOTO END1
GOTO A1
+2 SET DGRM=^TMP("DGZPTL",$JOB,"BED",DGW,DGR)
+3 SET (DFN,DGNM,DGAD,DGSER,DGDX,DGPRV,DGCOM,DGCHART,AGE,DGLOS,DGDS)=""
+4 SET DGBED=$PIECE(DGRM,"-",2,3)
+5 IF '$DATA(^TMP("DGZPTL",$JOB,"WD",DGRM))
GOTO PRNT
SET DGSTR=^(DGRM)
+6 SET DFN=$PIECE(DGSTR,U)
+7 SET DGNM=$PIECE(DGSTR,U,2)
SET DGDS=$PIECE(DGSTR,U,7)
SET DGCOM=$PIECE(DGSTR,U,6)
+8 SET DGAD=$PIECE(DGSTR,U,3)
SET DGDX=$PIECE(DGSTR,U,4)
SET DGPRV=$PIECE(DGSTR,U,5)
+9 IF DGPRV?1N.N
SET DGPRV=$PIECE(^VA(200,DGPRV,0),U)
+10 SET DGCHART=$PIECE(^AUPNPAT(DFN,41,DUZ(2),0),U,2)
SET DGXX=6-$LENGTH(DGCHART)
+11 FOR DGII=1:1:DGXX
SET DGCHART="0"_DGCHART
+12 KILL ^UTILITY("DIQ1",$JOB)
+13 SET DA=DFN
SET DIC=2
SET DR=.033
DO EN^DIQ1
+14 SET AGE=^UTILITY("DIQ1",$JOB,2,DFN,.033)
+15 KILL ^UTILTIY("DIQ1",$JOB)
+16 IF DGAD'=""
SET X=$PIECE(DGAD,".",1)
DO H^%DTC
SET DGLOS=(+$HOROLOG-+%H)+1
+17 IF DGO=2
IF DGDX]""
SET DGSER=DGDX
+18 IF DGO=2
IF DGDX?1N.N
SET DGSER=$EXTRACT($PIECE(^DIC(45.7,DGDX,0),U),1,20)
+19 ;
PRNT IF $Y>(IOSL-5)
DO NEWPG
IF DGSTOP=U
GOTO END1
+1 WRITE !,DGDS,?3,DGBED,?9,$EXTRACT(DGNM,1,20)
+2 IF DGCHART
WRITE ?31,$EXTRACT(DGCHART,1,2)_"-"_$EXTRACT(DGCHART,3,4)_"-"_$EXTRACT(DGCHART,5,6)
+3 WRITE ?42,AGE
+4 IF DGO=4
Begin DoDot:1
+5 IF DFN
SET X="SRZPEP"
XECUTE ^%ZOSF("TEST")
IF $TEST
WRITE ?50,$$SDA^SRZPEP(DFN)
+6 WRITE !
+7 IF DGDX'=""
WRITE ?20,"(",$EXTRACT(DGDX,1,25),")"
End DoDot:1
GOTO PRNT1
+8 WRITE ?47,$JUSTIFY(DGLOS,2)
+9 WRITE ?53,$SELECT(DGO=1:$EXTRACT(DGDX,1,25),DGO=2:DGSER,1:"")
+10 WRITE !
IF DGPRV'=""
WRITE ?11,"(",$EXTRACT(DGPRV,1,15),")"
+11 IF DGCOM'=""
WRITE ?33,"(",DGCOM,")"
+12 IF DFN
SET X="SRZPEP"
XECUTE ^%ZOSF("TEST")
IF $TEST
WRITE ?50,$$SDA^SRZPEP(DFN)
PRNT1 WRITE !,DGLIN
GOTO A2
+1 ;
+2 ;
END ;***> eoj
+1 IF IOST?1"C-".E
KILL DIR
SET DIR(0)="E"
DO ^DIR
DO ^XBCLS
END1 ;EP
+1 ;D ^%ZISC W ! **CRG 2/19/97
+2 WRITE !
DO ^%ZISC
+3 DO KILL^ADGUTIL
+4 KILL ^TMP("DGZPTL",$JOB)
QUIT
+5 ;
+6 ;
NEWPG ;EP;***> 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-")!(DGPG>0)
WRITE @IOF
+2 WRITE !,DGLIN1
SET DGPG=DGPG+1
+3 WRITE !?11,"*****Confidential Patient Data Covered by Privacy Act*****"
+4 WRITE !,DGDUZ,?80-$LENGTH(DGSITE)/2,DGSITE
SET DGTY="INPATIENT ROSTER"
+5 WRITE !
DO TIME^ADGUTIL
WRITE ?80-$LENGTH(DGTY)/2,DGTY,?70,"Page: ",DGPG
+6 SET Y=DT
XECUTE ^DD("DD")
WRITE !,Y
+7 SET DGWARD="*** "_$PIECE(^DIC(42,DGW,0),U)_" ***"
WRITE ?80-$LENGTH(DGWARD)/2,DGWARD
+8 WRITE !,DGLIN1
+9 WRITE !?3,"Room",?9,"Patient",?31,"Chart #",?41,"Age"
+10 IF DGO=4
WRITE ?55,"Nursing Notes",!?20,"(Admitting Diagnosis)"
GOTO HD1
+11 WRITE ?46,"LOS",?61,$SELECT(DGO=1:"Admitting",DGO=2:"Service",1:"")
+12 WRITE !?11,"(Provider)",?33,"(Community)",?61
IF DGO=1
WRITE "Diagnosis"
HD1 WRITE !,DGLIN,!
+1 QUIT
