- ADGADSP1 ; IHS/ADC/PDW/ENM - A & D SHEET PRINT (DETAILED) ; [ 03/25/1999 11:48 AM ]
- ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
- ;
- ;detailed version continued
- G END:'$D(^TMP("DGZADS",$J,"ZZ")) S DGCNT=^("ZZ")
- S DGK=0
- ;
- ;***> print data for admits,discharges,newborns,deaths,&seriously ill
- LOOP F DGI="AA","AD","AN","DN","DT","SI" D
- .S DGK=DGK+1,DGNM=0 ;initialize variables
- .D NEWPG:$Y>(IOSL-5) ;form feed if at end of page
- .W !,$P($T(LABEL+DGK),";;",2)," ",$P(DGCNT,U,DGK) ;print totals
- .F Q:DGNM="" D ;loop thru by patient name
- ..S DGNM=$O(^TMP("DGZADS",$J,DGI,DGNM)) Q:DGNM="" ;
- ..S DGCHT=0 F Q:DGCHT="" D ;within name loop by chart & print data
- ...S DGCHT=$O(^TMP("DGZADS",$J,DGI,DGNM,DGCHT)) Q:DGCHT="" ;
- ...S DGADM=0 F Q:DGADM="" D ;w/in chart loop by admit # & print data
- ....S DGADM=$O(^TMP("DGZADS",$J,DGI,DGNM,DGCHT,DGADM)) Q:DGADM=""
- ....S DGSTR=^TMP("DGZADS",$J,DGI,DGNM,DGCHT,DGADM) D WRITE
- ;
- ;
- TRANSF ;***> print transfers
- D NEWPG:$Y>(IOSL-5) W !,"WARD TRANSFERS: ",$P(DGCNT,U,7)
- G H1:'$D(^TMP("DGZADS",$J,"WT")) ;skip if no ward transfers
- S DGNM=0 ;get ward transfers by patient name
- G2 S DGNM=$O(^TMP("DGZADS",$J,"WT",DGNM)) G H1:DGNM="" S DFN=0
- G3 S DFN=$O(^TMP("DGZADS",$J,"WT",DGNM,DFN)) G G2:DFN="" S DGTRN=0
- G4 S DGTRN=$O(^TMP("DGZADS",$J,"WT",DGNM,DFN,DGTRN)) G G3:DGTRN=""
- S DGSTR=^TMP("DGZADS",$J,"WT",DGNM,DFN,DGTRN) D NEWPG:$Y>(IOSL-7)
- S DGX=$P(DGSTR,U) I DGX'="" S DGX=$P($G(^DIC(42,DGX,0)),U) ;prev ward
- S DGX1=$P(DGSTR,U,2) I DGX1'="" S DGX1=$P($G(^DIC(42,DGX1,0)),U) ;new
- W !?10,DGNM," from ",DGX," to ",DGX1 G G4
- ;
- H1 D NEWPG:$Y>(IOSL-5) W !,"TREATING SPECIALTY TRANSFERS: ",$P(DGCNT,U,8)
- G END:'$D(^TMP("DGZADS",$J,"TS")) ;skip if no service transfers
- S DGNM=0 ;get service transfers by patient name
- H2 S DGNM=$O(^TMP("DGZADS",$J,"TS",DGNM)) G END:DGNM="" S DFN=0
- H3 S DFN=$O(^TMP("DGZADS",$J,"TS",DGNM,DFN)) G H2:DFN="" S DGTST=0
- H4 S DGTST=$O(^TMP("DGZADS",$J,"TS",DGNM,DFN,DGTST)) G H3:DGTST=""
- S DGSTR=^TMP("DGZADS",$J,"TS",DGNM,DFN,DGTST) D NEWPG:$Y>(IOSL-7)
- S DGX=$P(DGSTR,U) I DGX'="" S DGX=$P($G(^DIC(45.7,DGX,0)),U) ;old srv
- S DGX1=$P(DGSTR,U,2) I DGX1'="" S DGX1=$P($G(^DIC(45.7,DGX1,0)),U) ;new
- W !?10,DGNM," from ",DGX," to ",DGX1 G H4
- ;
- ;
- END G:$D(^ADGDS("AA")) ^ADGADSP2 ;day surgery print
- ;
- END1 ;EP;***> ending point for A&D print rtns
- I IOST["C-" K DIR S DIR("A")="Press RETURN to continue",DIR(0)="E" D ^DIR
- W @IOF S X=IOM X ^%ZOSF("RM") ;restore right margin
- D KILL^ADGUTIL
- K ^TMP("DGZADS",$J)
- D ^%ZISC Q
- ;
- ;
- WRITE ;***> subrtn to print each line
- W !?10,$E(DGNM,1,24) ;patient name
- ;S DGCHTX="00000"_DGCHT,DGCHTX=$E(DGCHTX,$L(DGCHTX)-5,$L(DGCHTX))
- ;W ?37,$E(DGCHTX,1,2)_"-"_$E(DGCHTX,3,4)_"-"_$E(DGCHTX,5,6)
- W ?37,DGCHT
- S DGPR=$P(DGSTR,U) ;admitting provider
- I DGPR'="" S DGPR=$E($P($G(^VA(200,DGPR,0)),U),1,21)
- W ?47,DGPR,?71,$P(DGSTR,U,2) ;print provider & age
- S DGX=$P(DGSTR,U,3) I DGX'="" W ?80,$P($G(^DIC(42,DGX,0)),U) ;ward/srv
- S DGX=$P(DGSTR,U,4) I DGX'="" W ?84,$E($P($G(^DIC(45.7,DGX,0)),U),1,3)
- W ?90,$E($P(DGSTR,U,5),1,12) ;community
- S DGDST=$P(DGSTR,U,6) G W5:DGDST="" ;skip if no transfer facility
- S DGX=@(U_$P(DGDST,";",2)_+DGDST_",0)") ;variable pointer
- W !?17,"Transfer Facility: ",$P(DGX,U)
- W5 D:$Y>(IOSL-5) NEWPG
- W9 Q
- ;
- NEWPG ;EP;***> subrtn for end of page control
- I IOST["C-" K DIR S DIR("A")="Press RETURN to continue",DIR(0)="E" D ^DIR
- W @IOF
- NP9 W !?26,"*****Confidential Patient Data Covered by Privacy Act*****",!
- Q
- ;
- LABEL ;;
- ;;ADMISSIONS:
- ;;DISCHARGES:
- ;;NEWBORN ADMISSIONS:
- ;;NEWBORN DISCHARGES:
- ;;DEATHS:
- ;;SERIOUSLY ILL:
- ADGADSP1 ; IHS/ADC/PDW/ENM - A & D SHEET PRINT (DETAILED) ; [ 03/25/1999 11:48 AM ]
- +1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
- +2 ;
- +3 ;detailed version continued
- +4 IF '$DATA(^TMP("DGZADS",$JOB,"ZZ"))
- GOTO END
- SET DGCNT=^("ZZ")
- +5 SET DGK=0
- +6 ;
- +7 ;***> print data for admits,discharges,newborns,deaths,&seriously ill
- LOOP FOR DGI="AA","AD","AN","DN","DT","SI"
- Begin DoDot:1
- +1 ;initialize variables
- SET DGK=DGK+1
- SET DGNM=0
- +2 ;form feed if at end of page
- IF $Y>(IOSL-5)
- DO NEWPG
- +3 ;print totals
- WRITE !,$PIECE($TEXT(LABEL+DGK),";;",2)," ",$PIECE(DGCNT,U,DGK)
- +4 ;loop thru by patient name
- FOR
- IF DGNM=""
- QUIT
- Begin DoDot:2
- +5 ;
- SET DGNM=$ORDER(^TMP("DGZADS",$JOB,DGI,DGNM))
- IF DGNM=""
- QUIT
- +6 ;within name loop by chart & print data
- SET DGCHT=0
- FOR
- IF DGCHT=""
- QUIT
- Begin DoDot:3
- +7 ;
- SET DGCHT=$ORDER(^TMP("DGZADS",$JOB,DGI,DGNM,DGCHT))
- IF DGCHT=""
- QUIT
- +8 ;w/in chart loop by admit # & print data
- SET DGADM=0
- FOR
- IF DGADM=""
- QUIT
- Begin DoDot:4
- +9 SET DGADM=$ORDER(^TMP("DGZADS",$JOB,DGI,DGNM,DGCHT,DGADM))
- IF DGADM=""
- QUIT
- +10 SET DGSTR=^TMP("DGZADS",$JOB,DGI,DGNM,DGCHT,DGADM)
- DO WRITE
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +11 ;
- +12 ;
- TRANSF ;***> print transfers
- +1 IF $Y>(IOSL-5)
- DO NEWPG
- WRITE !,"WARD TRANSFERS: ",$PIECE(DGCNT,U,7)
- +2 ;skip if no ward transfers
- IF '$DATA(^TMP("DGZADS",$JOB,"WT"))
- GOTO H1
- +3 ;get ward transfers by patient name
- SET DGNM=0
- G2 SET DGNM=$ORDER(^TMP("DGZADS",$JOB,"WT",DGNM))
- IF DGNM=""
- GOTO H1
- SET DFN=0
- G3 SET DFN=$ORDER(^TMP("DGZADS",$JOB,"WT",DGNM,DFN))
- IF DFN=""
- GOTO G2
- SET DGTRN=0
- G4 SET DGTRN=$ORDER(^TMP("DGZADS",$JOB,"WT",DGNM,DFN,DGTRN))
- IF DGTRN=""
- GOTO G3
- +1 SET DGSTR=^TMP("DGZADS",$JOB,"WT",DGNM,DFN,DGTRN)
- IF $Y>(IOSL-7)
- DO NEWPG
- +2 ;prev ward
- SET DGX=$PIECE(DGSTR,U)
- IF DGX'=""
- SET DGX=$PIECE($GET(^DIC(42,DGX,0)),U)
- +3 ;new
- SET DGX1=$PIECE(DGSTR,U,2)
- IF DGX1'=""
- SET DGX1=$PIECE($GET(^DIC(42,DGX1,0)),U)
- +4 WRITE !?10,DGNM," from ",DGX," to ",DGX1
- GOTO G4
- +5 ;
- H1 IF $Y>(IOSL-5)
- DO NEWPG
- WRITE !,"TREATING SPECIALTY TRANSFERS: ",$PIECE(DGCNT,U,8)
- +1 ;skip if no service transfers
- IF '$DATA(^TMP("DGZADS",$JOB,"TS"))
- GOTO END
- +2 ;get service transfers by patient name
- SET DGNM=0
- H2 SET DGNM=$ORDER(^TMP("DGZADS",$JOB,"TS",DGNM))
- IF DGNM=""
- GOTO END
- SET DFN=0
- H3 SET DFN=$ORDER(^TMP("DGZADS",$JOB,"TS",DGNM,DFN))
- IF DFN=""
- GOTO H2
- SET DGTST=0
- H4 SET DGTST=$ORDER(^TMP("DGZADS",$JOB,"TS",DGNM,DFN,DGTST))
- IF DGTST=""
- GOTO H3
- +1 SET DGSTR=^TMP("DGZADS",$JOB,"TS",DGNM,DFN,DGTST)
- IF $Y>(IOSL-7)
- DO NEWPG
- +2 ;old srv
- SET DGX=$PIECE(DGSTR,U)
- IF DGX'=""
- SET DGX=$PIECE($GET(^DIC(45.7,DGX,0)),U)
- +3 ;new
- SET DGX1=$PIECE(DGSTR,U,2)
- IF DGX1'=""
- SET DGX1=$PIECE($GET(^DIC(45.7,DGX1,0)),U)
- +4 WRITE !?10,DGNM," from ",DGX," to ",DGX1
- GOTO H4
- +5 ;
- +6 ;
- END ;day surgery print
- IF $DATA(^ADGDS("AA"))
- GOTO ^ADGADSP2
- +1 ;
- END1 ;EP;***> ending point for A&D print rtns
- +1 IF IOST["C-"
- KILL DIR
- SET DIR("A")="Press RETURN to continue"
- SET DIR(0)="E"
- DO ^DIR
- +2 ;restore right margin
- WRITE @IOF
- SET X=IOM
- XECUTE ^%ZOSF("RM")
- +3 DO KILL^ADGUTIL
- +4 KILL ^TMP("DGZADS",$JOB)
- +5 DO ^%ZISC
- QUIT
- +6 ;
- +7 ;
- WRITE ;***> subrtn to print each line
- +1 ;patient name
- WRITE !?10,$EXTRACT(DGNM,1,24)
- +2 ;S DGCHTX="00000"_DGCHT,DGCHTX=$E(DGCHTX,$L(DGCHTX)-5,$L(DGCHTX))
- +3 ;W ?37,$E(DGCHTX,1,2)_"-"_$E(DGCHTX,3,4)_"-"_$E(DGCHTX,5,6)
- +4 WRITE ?37,DGCHT
- +5 ;admitting provider
- SET DGPR=$PIECE(DGSTR,U)
- +6 IF DGPR'=""
- SET DGPR=$EXTRACT($PIECE($GET(^VA(200,DGPR,0)),U),1,21)
- +7 ;print provider & age
- WRITE ?47,DGPR,?71,$PIECE(DGSTR,U,2)
- +8 ;ward/srv
- SET DGX=$PIECE(DGSTR,U,3)
- IF DGX'=""
- WRITE ?80,$PIECE($GET(^DIC(42,DGX,0)),U)
- +9 SET DGX=$PIECE(DGSTR,U,4)
- IF DGX'=""
- WRITE ?84,$EXTRACT($PIECE($GET(^DIC(45.7,DGX,0)),U),1,3)
- +10 ;community
- WRITE ?90,$EXTRACT($PIECE(DGSTR,U,5),1,12)
- +11 ;skip if no transfer facility
- SET DGDST=$PIECE(DGSTR,U,6)
- IF DGDST=""
- GOTO W5
- +12 ;variable pointer
- SET DGX=@(U_$PIECE(DGDST,";",2)_+DGDST_",0)")
- +13 WRITE !?17,"Transfer Facility: ",$PIECE(DGX,U)
- W5 IF $Y>(IOSL-5)
- DO NEWPG
- W9 QUIT
- +1 ;
- NEWPG ;EP;***> subrtn for end of page control
- +1 IF IOST["C-"
- KILL DIR
- SET DIR("A")="Press RETURN to continue"
- SET DIR(0)="E"
- DO ^DIR
- +2 WRITE @IOF
- NP9 WRITE !?26,"*****Confidential Patient Data Covered by Privacy Act*****",!
- +1 QUIT
- +2 ;
- LABEL ;;
- +1 ;;ADMISSIONS:
- +2 ;;DISCHARGES:
- +3 ;;NEWBORN ADMISSIONS:
- +4 ;;NEWBORN DISCHARGES:
- +5 ;;DEATHS:
- +6 ;;SERIOUSLY ILL:
