- 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
