- ADGADSP4 ; IHS/ADC/PDW/ENM - A & D SHEET PRINT (SUMMARY) ; [ 03/25/1999 11:48 AM ]
- ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
- ;
- ;***> Summary version of ADMISSIONS & DISCHARGES SHEET
- ;***> prints patient data
- ;
- W !!!! I $Y>(IOSL-5) D NEWPG^ADGADSP3 G END1^ADGADSP5:DGSTOP=U
- W:$D(^TMP("DGZADS",$J,"AA")) ?4,"ADMISSIONS TO HOSPITAL"
- W:$D(^TMP("DGZADS",$J,"AD")) ?48,"DISCHARGES FROM HOSPITAL"
- W ! I $D(^TMP("DGZADS",$J,"AA")) W DGLIN
- I $D(^TMP("DGZADS",$J,"AD")) W ?42,DGLIN
- ;
- ;***> loop thru admissions
- W ! S (DGNM,DGI)=0
- A1 S DGNM=$O(^TMP("DGZADS",$J,"AA",DGNM)) G B1:DGNM="" S DGCHT=0
- A2 S DGCHT=$O(^TMP("DGZADS",$J,"AA",DGNM,DGCHT)) G A1:DGCHT="" S DGM=0
- A3 S DGM=$O(^TMP("DGZADS",$J,"AA",DGNM,DGCHT,DGM)) G A2:DGM=""
- S DGSTR=^TMP("DGZADS",$J,"AA",DGNM,DGCHT,DGM) D LINE1 G A3
- ;
- ;***> loop thru discharges
- B1 S (DGNM,DGI)=0
- B2 S DGNM=$O(^TMP("DGZADS",$J,"AD",DGNM)) G B5:DGNM="" S DGCHT=0
- B3 S DGCHT=$O(^TMP("DGZADS",$J,"AD",DGNM,DGCHT)) G B2:DGCHT="" S DGM=0
- B4 S DGM=$O(^TMP("DGZADS",$J,"AD",DGNM,DGCHT,DGM)) G B3:DGM=""
- S DGSTR=^TMP("DGZADS",$J,"AD",DGNM,DGCHT,DGM) D LINE2 G B4
- ;
- ;***> print admits and discharges from local array
- B5 F DGI=1:1 Q:'$D(DGL(DGI)) D Q:DGSTOP=U
- .W !,DGL(DGI),?42,DGL(DGI,0)
- .I $Y>(IOSL-5) D NEWPG^ADGADSP3
- G END1^ADGADSP5:DGSTOP=U
- K DGL,DGI
- ;
- C1 W !! I $Y>(IOSL-5) D NEWPG^ADGADSP3 G END1^ADGADSP5:DGSTOP=U
- W:$D(^TMP("DGZADS",$J,"AN")) ?6,"NEWBORN ADMISSIONS"
- W:$D(^TMP("DGZADS",$J,"DN")) ?47,"NEWBORN DISCHARGES"
- W ! I $D(^TMP("DGZADS",$J,"AN")) W DGLIN
- I $D(^TMP("DGZADS",$J,"DN")) W ?42,DGLIN
- ;
- ;***> loop thru newborn admissions
- W ! S (DGNM,DGI)=0
- C2 S DGNM=$O(^TMP("DGZADS",$J,"AN",DGNM)) G D1:DGNM="" S DGCHT=0
- C3 S DGCHT=$O(^TMP("DGZADS",$J,"AN",DGNM,DGCHT)) G C2:DGCHT="" S DGM=0
- C4 S DGM=$O(^TMP("DGZADS",$J,"AN",DGNM,DGCHT,DGM)) G C3:DGM=""
- S DGSTR=^TMP("DGZADS",$J,"AN",DGNM,DGCHT,DGM) D LINE1 G C4
- ;
- ;***> loop thru newborn discharges
- D1 S (DGNM,DGI)=0
- D2 S DGNM=$O(^TMP("DGZADS",$J,"DN",DGNM)) G D5:DGNM="" S DGCHT=0
- D3 S DGCHT=$O(^TMP("DGZADS",$J,"DN",DGNM,DGCHT)) G D2:DGCHT="" S DGM=0
- D4 S DGM=$O(^TMP("DGZADS",$J,"DN",DGNM,DGCHT,DGM)) G D3:DGM=""
- S DGSTR=^TMP("DGZADS",$J,"DN",DGNM,DGCHT,DGM) D LINE2 G D4
- ;
- ;***> print newborn admits and discharges from local array
- D5 F DGI=1:1 Q:'$D(DGL(DGI)) D Q:DGSTOP=U
- . W !,DGL(DGI),?42,DGL(DGI,0)
- . I $Y>(IOSL-5) D NEWPG^ADGADSP3
- G END1^ADGADSP5:DGSTOP=U
- K DGL,DGI
- ;
- E1 W !! I $Y>(IOSL-5) D NEWPG^ADGADSP3 G END1^ADGADSP5:DGSTOP=U
- G END:'$D(^TMP("DGZADS",$J,"WT"))
- W ?6,"WARD TRANSFERS IN",?47,"WARD TRANSFERS OUT",!,DGLIN,?42,DGLIN,!
- ;
- ;***> loop thru ward transfers
- S (DGNM,DGI)=0
- E2 S DGNM=$O(^TMP("DGZADS",$J,"WT",DGNM)) G END:DGNM="" S DFN=0
- E3 S DFN=$O(^TMP("DGZADS",$J,"WT",DGNM,DFN)) G E2:DFN="" S DGTRN=0
- E4 S DGTRN=$O(^TMP("DGZADS",$J,"WT",DGNM,DFN,DGTRN)) G E3:DGTRN=""
- S DGSTR=^TMP("DGZADS",$J,"WT",DGNM,DFN,DGTRN)
- S DGX=$P(DGSTR,U) I DGX'="" S DGX=$P($G(^DIC(42,DGX,0)),U) ;old ward
- S DGX1=$P(DGSTR,U,2) I DGX1'="" S DGX1=$P($G(^DIC(42,DGX1,0)),U) ;new
- S DGCHT=$P(^AUPNPAT(DFN,41,DUZ(2),0),U,2) ;chart #
- S DGCHT="00000"_DGCHT,DGCHT=$E(DGCHT,$L(DGCHT)-5,$L(DGCHT))
- S DGCHT=$E(DGCHT,1,2)_"-"_$E(DGCHT,3,4)_"-"_$E(DGCHT,5,6)
- W !,$E(DGX1,1,3),?5,DGCHT," ",$E(DGNM,1,20),?42,$E(DGX,1,3)
- W ?47,DGCHT," ",$E(DGNM,1,20) G E4
- I $Y>(IOSL-5) D NEWPG^ADGADSP3 G END1^ADGADSP5:DGSTOP=U
- ;
- END G ^ADGADSP5 ;continue print
- ;
- ;
- LINE1 ;EP;***> set column 1 data
- S DGI=DGI+1 ;increment array subscript
- S DGX=$P(DGSTR,U,4) ;set service
- I DGX'="" S DGL(DGI)=$E($P($G(^DIC(45.7,DGX,0)),U),1,3)
- ;ward
- S DGX=$P(DGSTR,U,3),DGL(DGI)=DGL(DGI)_" "_$E($P(^DIC(42,DGX,0),U)_" ",1,3)
- ;S DGCHTX="00000"_DGCHT,DGCHTX=$E(DGCHTX,$L(DGCHTX)-5,$L(DGCHTX))
- ;S DGCHTX=$E(DGCHTX,1,2)_"-"_$E(DGCHTX,3,4)_"-"_$E(DGCHTX,5,6)
- ;S DGL(DGI)=DGL(DGI)_" "_DGCHTX_" "_$E(DGNM,1,17),DGL(DGI,0)=""
- S DGL(DGI)=DGL(DGI)_" "_$J(DGCHT,6)_" "_$E(DGNM,1,17),DGL(DGI,0)=""
- Q
- ;
- LINE2 ;EP;***> set column 2 data
- S DGI=DGI+1 I '$D(DGL(DGI)) S DGL(DGI)=""
- S DGX=$P(DGSTR,U,4) ;set service
- I DGX'="" S DGL(DGI,0)=$E($P($G(^DIC(45.7,DGX,0)),U),1,3)
- S DGX=$P(DGSTR,U,3),DGL(DGI,0)=DGL(DGI,0)_" "_$E($P(^DIC(42,DGX,0),U)_" ",1,3)
- ;S DGCHTX="00000"_DGCHT,DGCHTX=$E(DGCHTX,$L(DGCHTX)-5,$L(DGCHTX))
- ;S DGCHTX=$E(DGCHTX,1,2)_"-"_$E(DGCHTX,3,4)_"-"_$E(DGCHTX,5,6)
- ;S DGL(DGI,0)=DGL(DGI,0)_" "_DGCHTX_" "_$E(DGNM,1,17)
- S DGL(DGI,0)=DGL(DGI,0)_" "_$J(DGCHT,6)_" "_$E(DGNM,1,17)
- Q
- ADGADSP4 ; IHS/ADC/PDW/ENM - A & D SHEET PRINT (SUMMARY) ; [ 03/25/1999 11:48 AM ]
- +1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
- +2 ;
- +3 ;***> Summary version of ADMISSIONS & DISCHARGES SHEET
- +4 ;***> prints patient data
- +5 ;
- +6 WRITE !!!!
- IF $Y>(IOSL-5)
- DO NEWPG^ADGADSP3
- IF DGSTOP=U
- GOTO END1^ADGADSP5
- +7 IF $DATA(^TMP("DGZADS",$JOB,"AA"))
- WRITE ?4,"ADMISSIONS TO HOSPITAL"
- +8 IF $DATA(^TMP("DGZADS",$JOB,"AD"))
- WRITE ?48,"DISCHARGES FROM HOSPITAL"
- +9 WRITE !
- IF $DATA(^TMP("DGZADS",$JOB,"AA"))
- WRITE DGLIN
- +10 IF $DATA(^TMP("DGZADS",$JOB,"AD"))
- WRITE ?42,DGLIN
- +11 ;
- +12 ;***> loop thru admissions
- +13 WRITE !
- SET (DGNM,DGI)=0
- A1 SET DGNM=$ORDER(^TMP("DGZADS",$JOB,"AA",DGNM))
- IF DGNM=""
- GOTO B1
- SET DGCHT=0
- A2 SET DGCHT=$ORDER(^TMP("DGZADS",$JOB,"AA",DGNM,DGCHT))
- IF DGCHT=""
- GOTO A1
- SET DGM=0
- A3 SET DGM=$ORDER(^TMP("DGZADS",$JOB,"AA",DGNM,DGCHT,DGM))
- IF DGM=""
- GOTO A2
- +1 SET DGSTR=^TMP("DGZADS",$JOB,"AA",DGNM,DGCHT,DGM)
- DO LINE1
- GOTO A3
- +2 ;
- +3 ;***> loop thru discharges
- B1 SET (DGNM,DGI)=0
- B2 SET DGNM=$ORDER(^TMP("DGZADS",$JOB,"AD",DGNM))
- IF DGNM=""
- GOTO B5
- SET DGCHT=0
- B3 SET DGCHT=$ORDER(^TMP("DGZADS",$JOB,"AD",DGNM,DGCHT))
- IF DGCHT=""
- GOTO B2
- SET DGM=0
- B4 SET DGM=$ORDER(^TMP("DGZADS",$JOB,"AD",DGNM,DGCHT,DGM))
- IF DGM=""
- GOTO B3
- +1 SET DGSTR=^TMP("DGZADS",$JOB,"AD",DGNM,DGCHT,DGM)
- DO LINE2
- GOTO B4
- +2 ;
- +3 ;***> print admits and discharges from local array
- B5 FOR DGI=1:1
- IF '$DATA(DGL(DGI))
- QUIT
- Begin DoDot:1
- +1 WRITE !,DGL(DGI),?42,DGL(DGI,0)
- +2 IF $Y>(IOSL-5)
- DO NEWPG^ADGADSP3
- End DoDot:1
- IF DGSTOP=U
- QUIT
- +3 IF DGSTOP=U
- GOTO END1^ADGADSP5
- +4 KILL DGL,DGI
- +5 ;
- C1 WRITE !!
- IF $Y>(IOSL-5)
- DO NEWPG^ADGADSP3
- IF DGSTOP=U
- GOTO END1^ADGADSP5
- +1 IF $DATA(^TMP("DGZADS",$JOB,"AN"))
- WRITE ?6,"NEWBORN ADMISSIONS"
- +2 IF $DATA(^TMP("DGZADS",$JOB,"DN"))
- WRITE ?47,"NEWBORN DISCHARGES"
- +3 WRITE !
- IF $DATA(^TMP("DGZADS",$JOB,"AN"))
- WRITE DGLIN
- +4 IF $DATA(^TMP("DGZADS",$JOB,"DN"))
- WRITE ?42,DGLIN
- +5 ;
- +6 ;***> loop thru newborn admissions
- +7 WRITE !
- SET (DGNM,DGI)=0
- C2 SET DGNM=$ORDER(^TMP("DGZADS",$JOB,"AN",DGNM))
- IF DGNM=""
- GOTO D1
- SET DGCHT=0
- C3 SET DGCHT=$ORDER(^TMP("DGZADS",$JOB,"AN",DGNM,DGCHT))
- IF DGCHT=""
- GOTO C2
- SET DGM=0
- C4 SET DGM=$ORDER(^TMP("DGZADS",$JOB,"AN",DGNM,DGCHT,DGM))
- IF DGM=""
- GOTO C3
- +1 SET DGSTR=^TMP("DGZADS",$JOB,"AN",DGNM,DGCHT,DGM)
- DO LINE1
- GOTO C4
- +2 ;
- +3 ;***> loop thru newborn discharges
- D1 SET (DGNM,DGI)=0
- D2 SET DGNM=$ORDER(^TMP("DGZADS",$JOB,"DN",DGNM))
- IF DGNM=""
- GOTO D5
- SET DGCHT=0
- D3 SET DGCHT=$ORDER(^TMP("DGZADS",$JOB,"DN",DGNM,DGCHT))
- IF DGCHT=""
- GOTO D2
- SET DGM=0
- D4 SET DGM=$ORDER(^TMP("DGZADS",$JOB,"DN",DGNM,DGCHT,DGM))
- IF DGM=""
- GOTO D3
- +1 SET DGSTR=^TMP("DGZADS",$JOB,"DN",DGNM,DGCHT,DGM)
- DO LINE2
- GOTO D4
- +2 ;
- +3 ;***> print newborn admits and discharges from local array
- D5 FOR DGI=1:1
- IF '$DATA(DGL(DGI))
- QUIT
- Begin DoDot:1
- +1 WRITE !,DGL(DGI),?42,DGL(DGI,0)
- +2 IF $Y>(IOSL-5)
- DO NEWPG^ADGADSP3
- End DoDot:1
- IF DGSTOP=U
- QUIT
- +3 IF DGSTOP=U
- GOTO END1^ADGADSP5
- +4 KILL DGL,DGI
- +5 ;
- E1 WRITE !!
- IF $Y>(IOSL-5)
- DO NEWPG^ADGADSP3
- IF DGSTOP=U
- GOTO END1^ADGADSP5
- +1 IF '$DATA(^TMP("DGZADS",$JOB,"WT"))
- GOTO END
- +2 WRITE ?6,"WARD TRANSFERS IN",?47,"WARD TRANSFERS OUT",!,DGLIN,?42,DGLIN,!
- +3 ;
- +4 ;***> loop thru ward transfers
- +5 SET (DGNM,DGI)=0
- E2 SET DGNM=$ORDER(^TMP("DGZADS",$JOB,"WT",DGNM))
- IF DGNM=""
- GOTO END
- SET DFN=0
- E3 SET DFN=$ORDER(^TMP("DGZADS",$JOB,"WT",DGNM,DFN))
- IF DFN=""
- GOTO E2
- SET DGTRN=0
- E4 SET DGTRN=$ORDER(^TMP("DGZADS",$JOB,"WT",DGNM,DFN,DGTRN))
- IF DGTRN=""
- GOTO E3
- +1 SET DGSTR=^TMP("DGZADS",$JOB,"WT",DGNM,DFN,DGTRN)
- +2 ;old 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 ;chart #
- SET DGCHT=$PIECE(^AUPNPAT(DFN,41,DUZ(2),0),U,2)
- +5 SET DGCHT="00000"_DGCHT
- SET DGCHT=$EXTRACT(DGCHT,$LENGTH(DGCHT)-5,$LENGTH(DGCHT))
- +6 SET DGCHT=$EXTRACT(DGCHT,1,2)_"-"_$EXTRACT(DGCHT,3,4)_"-"_$EXTRACT(DGCHT,5,6)
- +7 WRITE !,$EXTRACT(DGX1,1,3),?5,DGCHT," ",$EXTRACT(DGNM,1,20),?42,$EXTRACT(DGX,1,3)
- +8 WRITE ?47,DGCHT," ",$EXTRACT(DGNM,1,20)
- GOTO E4
- +9 IF $Y>(IOSL-5)
- DO NEWPG^ADGADSP3
- IF DGSTOP=U
- GOTO END1^ADGADSP5
- +10 ;
- END ;continue print
- GOTO ^ADGADSP5
- +1 ;
- +2 ;
- LINE1 ;EP;***> set column 1 data
- +1 ;increment array subscript
- SET DGI=DGI+1
- +2 ;set service
- SET DGX=$PIECE(DGSTR,U,4)
- +3 IF DGX'=""
- SET DGL(DGI)=$EXTRACT($PIECE($GET(^DIC(45.7,DGX,0)),U),1,3)
- +4 ;ward
- +5 SET DGX=$PIECE(DGSTR,U,3)
- SET DGL(DGI)=DGL(DGI)_" "_$EXTRACT($PIECE(^DIC(42,DGX,0),U)_" ",1,3)
- +6 ;S DGCHTX="00000"_DGCHT,DGCHTX=$E(DGCHTX,$L(DGCHTX)-5,$L(DGCHTX))
- +7 ;S DGCHTX=$E(DGCHTX,1,2)_"-"_$E(DGCHTX,3,4)_"-"_$E(DGCHTX,5,6)
- +8 ;S DGL(DGI)=DGL(DGI)_" "_DGCHTX_" "_$E(DGNM,1,17),DGL(DGI,0)=""
- +9 SET DGL(DGI)=DGL(DGI)_" "_$JUSTIFY(DGCHT,6)_" "_$EXTRACT(DGNM,1,17)
- SET DGL(DGI,0)=""
- +10 QUIT
- +11 ;
- LINE2 ;EP;***> set column 2 data
- +1 SET DGI=DGI+1
- IF '$DATA(DGL(DGI))
- SET DGL(DGI)=""
- +2 ;set service
- SET DGX=$PIECE(DGSTR,U,4)
- +3 IF DGX'=""
- SET DGL(DGI,0)=$EXTRACT($PIECE($GET(^DIC(45.7,DGX,0)),U),1,3)
- +4 SET DGX=$PIECE(DGSTR,U,3)
- SET DGL(DGI,0)=DGL(DGI,0)_" "_$EXTRACT($PIECE(^DIC(42,DGX,0),U)_" ",1,3)
- +5 ;S DGCHTX="00000"_DGCHT,DGCHTX=$E(DGCHTX,$L(DGCHTX)-5,$L(DGCHTX))
- +6 ;S DGCHTX=$E(DGCHTX,1,2)_"-"_$E(DGCHTX,3,4)_"-"_$E(DGCHTX,5,6)
- +7 ;S DGL(DGI,0)=DGL(DGI,0)_" "_DGCHTX_" "_$E(DGNM,1,17)
- +8 SET DGL(DGI,0)=DGL(DGI,0)_" "_$JUSTIFY(DGCHT,6)_" "_$EXTRACT(DGNM,1,17)
- +9 QUIT
