- ADGADSP5 ; IHS/ADC/PDW/ENM - A & D SHEET PRINT (SUMMARY) ; [ 03/25/1999 11:48 AM ]
- ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
- ;
- ;***> Summary format of ADMISSIONS & DISCHARGES SHEET (cont.)
- ;
- A1 G B1:'$D(^TMP("DGZADS",$J,"TS"))
- W !! I $Y>(IOSL-5) D NEWPG^ADGADSP3 G END1:DGSTOP=U
- W ?6,"SERVICE TRANSFERS IN",?47,"SERVICE TRANSFERS OUT",!
- W DGLIN,?42,DGLIN,!
- ;
- ;***> loop thru service transfers
- S DGNM=0
- A2 S DGNM=$O(^TMP("DGZADS",$J,"TS",DGNM)) G B1:DGNM="" S DFN=0
- A3 S DFN=$O(^TMP("DGZADS",$J,"TS",DGNM,DFN)) G A2:DFN="" S DGTST=0
- A4 S DGTST=$O(^TMP("DGZADS",$J,"TS",DGNM,DFN,DGTST)) G A3:DGTST=""
- S DGSTR=^TMP("DGZADS",$J,"TS",DGNM,DFN,DGTST)
- 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
- 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)
- I $Y>(IOSL-5) D NEWPG^ADGADSP3 G END1:DGSTOP=U
- G A4
- ;
- B1 W !! I $Y>(IOSL-5) D NEWPG^ADGADSP3 G END1:DGSTOP=U
- W:$D(^TMP("DGZADS",$J,"AB1")) ?6,"RETURN FROM LEAVE"
- W:$D(^TMP("DGZADS",$J,"AB")) ?47,"ABSENT ON LEAVE"
- W ! I $D(^TMP("DGZADS",$J,"AB1")) W DGLIN
- I $D(^TMP("DGZADS",$J,"AB")) W ?42,DGLIN
- ;
- ;***> loop thru absences
- W ! S (DGNM,DGI)=0
- B2 S DGNM=$O(^TMP("DGZADS",$J,"AB1",DGNM)) G C1:DGNM="" S DFN=0
- B3 S DFN=$O(^TMP("DGZADS",$J,"AB1",DGNM,DFN)) G B2:DFN="" S DGTRN=0
- B4 S DGTRN=$O(^TMP("DGZADS",$J,"AB1",DGNM,DFN,DGTRN)) G B3:DGTRN=""
- S DGSTR=^TMP("DGZADS",$J,"AB1",DGNM,DFN,DGTRN) D LINE1^ADGADSP4 G B4
- ;
- C1 S (DGNM,DGI)=0
- C2 S DGNM=$O(^TMP("DGZADS",$J,"AB",DGNM)) G C5:DGNM="" S DFN=0
- C3 S DFN=$O(^TMP("DGZADS",$J,"AB",DGNM,DFN)) G C2:DFN="" S DGTRN=0
- C4 S DGTRN=$O(^TMP("DGZADS",$J,"AB",DGNM,DFN,DGTRN)) G C3:DGTRN=""
- S DGSTR=^TMP("DGZADS",$J,"AB",DGNM,DFN,DGTRN) D LINE2^ADGADSP4 G C4
- ;
- C5 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:DGSTOP=U
- K DGL,DGI
- ;
- D1 G NEXT:'$D(^TMP("DGZADS",$J,"DT"))
- W !! I $Y>(IOSL-5) D NEWPG^ADGADSP3 G END1:DGSTOP=U
- W ?52,"DEATHS",!?42,DGLIN,!
- ;
- ;***> loop thru deaths
- S (DGNM,DGI)=0
- D2 S DGNM=$O(^TMP("DGZADS",$J,"DT",DGNM)) G D5:DGNM="" S DGCHT=0
- D3 S DGCHT=$O(^TMP("DGZADS",$J,"DT",DGNM,DGCHT)) G D2:DGCHT="" S DGM=0
- D4 S DGM=$O(^TMP("DGZADS",$J,"DT",DGNM,DGCHT,DGM)) G D3:DGM=""
- S DGSTR=^TMP("DGZADS",$J,"DT",DGNM,DGCHT,DGM) D LINE2^ADGADSP4 G D4
- ;
- D5 F DGI=1:1 Q:'$D(DGL(DGI,0)) D Q:DGSTOP=U
- .W !?42,DGL(DGI,0)
- .I $Y>(IOSL-5) D NEWPG^ADGADSP3
- G END1:DGSTOP=U
- K DGL,DGI
- ;
- NEXT D ^ADGADSP6 ;day surgery print
- END I IOST["C-" K DIR S DIR("A")="Press RETURN to continue",DIR(0)="E" D ^DIR
- END1 ;EP;***> ending point for summary A&D Sheets
- W @IOF D KILL^ADGUTIL
- D ^%ZISC K ^TMP("DGZADS",$J)
- Q
- ;
- ADGADSP5 ; 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 format of ADMISSIONS & DISCHARGES SHEET (cont.)
- +4 ;
- A1 IF '$DATA(^TMP("DGZADS",$JOB,"TS"))
- GOTO B1
- +1 WRITE !!
- IF $Y>(IOSL-5)
- DO NEWPG^ADGADSP3
- IF DGSTOP=U
- GOTO END1
- +2 WRITE ?6,"SERVICE TRANSFERS IN",?47,"SERVICE TRANSFERS OUT",!
- +3 WRITE DGLIN,?42,DGLIN,!
- +4 ;
- +5 ;***> loop thru service transfers
- +6 SET DGNM=0
- A2 SET DGNM=$ORDER(^TMP("DGZADS",$JOB,"TS",DGNM))
- IF DGNM=""
- GOTO B1
- SET DFN=0
- A3 SET DFN=$ORDER(^TMP("DGZADS",$JOB,"TS",DGNM,DFN))
- IF DFN=""
- GOTO A2
- SET DGTST=0
- A4 SET DGTST=$ORDER(^TMP("DGZADS",$JOB,"TS",DGNM,DFN,DGTST))
- IF DGTST=""
- GOTO A3
- +1 SET DGSTR=^TMP("DGZADS",$JOB,"TS",DGNM,DFN,DGTST)
- +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 ;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)
- +9 IF $Y>(IOSL-5)
- DO NEWPG^ADGADSP3
- IF DGSTOP=U
- GOTO END1
- +10 GOTO A4
- +11 ;
- B1 WRITE !!
- IF $Y>(IOSL-5)
- DO NEWPG^ADGADSP3
- IF DGSTOP=U
- GOTO END1
- +1 IF $DATA(^TMP("DGZADS",$JOB,"AB1"))
- WRITE ?6,"RETURN FROM LEAVE"
- +2 IF $DATA(^TMP("DGZADS",$JOB,"AB"))
- WRITE ?47,"ABSENT ON LEAVE"
- +3 WRITE !
- IF $DATA(^TMP("DGZADS",$JOB,"AB1"))
- WRITE DGLIN
- +4 IF $DATA(^TMP("DGZADS",$JOB,"AB"))
- WRITE ?42,DGLIN
- +5 ;
- +6 ;***> loop thru absences
- +7 WRITE !
- SET (DGNM,DGI)=0
- B2 SET DGNM=$ORDER(^TMP("DGZADS",$JOB,"AB1",DGNM))
- IF DGNM=""
- GOTO C1
- SET DFN=0
- B3 SET DFN=$ORDER(^TMP("DGZADS",$JOB,"AB1",DGNM,DFN))
- IF DFN=""
- GOTO B2
- SET DGTRN=0
- B4 SET DGTRN=$ORDER(^TMP("DGZADS",$JOB,"AB1",DGNM,DFN,DGTRN))
- IF DGTRN=""
- GOTO B3
- +1 SET DGSTR=^TMP("DGZADS",$JOB,"AB1",DGNM,DFN,DGTRN)
- DO LINE1^ADGADSP4
- GOTO B4
- +2 ;
- C1 SET (DGNM,DGI)=0
- C2 SET DGNM=$ORDER(^TMP("DGZADS",$JOB,"AB",DGNM))
- IF DGNM=""
- GOTO C5
- SET DFN=0
- C3 SET DFN=$ORDER(^TMP("DGZADS",$JOB,"AB",DGNM,DFN))
- IF DFN=""
- GOTO C2
- SET DGTRN=0
- C4 SET DGTRN=$ORDER(^TMP("DGZADS",$JOB,"AB",DGNM,DFN,DGTRN))
- IF DGTRN=""
- GOTO C3
- +1 SET DGSTR=^TMP("DGZADS",$JOB,"AB",DGNM,DFN,DGTRN)
- DO LINE2^ADGADSP4
- GOTO C4
- +2 ;
- C5 FOR DGI=1:1
- IF '$DATA(DGL(DGI))
- QUIT
- Begin DoDot:1
- +1 WRITE !,DGL(DGI),?42,DGL(DGI,0)
- IF $Y>(IOSL-5)
- DO NEWPG^ADGADSP3
- End DoDot:1
- IF DGSTOP=U
- QUIT
- +2 IF DGSTOP=U
- GOTO END1
- +3 KILL DGL,DGI
- +4 ;
- D1 IF '$DATA(^TMP("DGZADS",$JOB,"DT"))
- GOTO NEXT
- +1 WRITE !!
- IF $Y>(IOSL-5)
- DO NEWPG^ADGADSP3
- IF DGSTOP=U
- GOTO END1
- +2 WRITE ?52,"DEATHS",!?42,DGLIN,!
- +3 ;
- +4 ;***> loop thru deaths
- +5 SET (DGNM,DGI)=0
- D2 SET DGNM=$ORDER(^TMP("DGZADS",$JOB,"DT",DGNM))
- IF DGNM=""
- GOTO D5
- SET DGCHT=0
- D3 SET DGCHT=$ORDER(^TMP("DGZADS",$JOB,"DT",DGNM,DGCHT))
- IF DGCHT=""
- GOTO D2
- SET DGM=0
- D4 SET DGM=$ORDER(^TMP("DGZADS",$JOB,"DT",DGNM,DGCHT,DGM))
- IF DGM=""
- GOTO D3
- +1 SET DGSTR=^TMP("DGZADS",$JOB,"DT",DGNM,DGCHT,DGM)
- DO LINE2^ADGADSP4
- GOTO D4
- +2 ;
- D5 FOR DGI=1:1
- IF '$DATA(DGL(DGI,0))
- QUIT
- Begin DoDot:1
- +1 WRITE !?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
- +4 KILL DGL,DGI
- +5 ;
- NEXT ;day surgery print
- DO ^ADGADSP6
- END IF IOST["C-"
- KILL DIR
- SET DIR("A")="Press RETURN to continue"
- SET DIR(0)="E"
- DO ^DIR
- END1 ;EP;***> ending point for summary A&D Sheets
- +1 WRITE @IOF
- DO KILL^ADGUTIL
- +2 DO ^%ZISC
- KILL ^TMP("DGZADS",$JOB)
- +3 QUIT
- +4 ;
