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
