ADGDSST ; IHS/ADC/PDW/ENM - DAY SURGERY STATISTICS BY SERVICE ; [ 12/16/2003 3:14 PM ]
;;5.0;ADMISSION/DISCHARGE/TRANSFER;**3**;MAR 25, 1999
;IHS/ITSC/WAR 12/16/03 Added call to 'old'(?) init of IHS variales
I '$D(DGOPT("GEN"))&($D(^DG(43,1,9999999))) D VAR^ADGVAR
I '$D(DGOPT("GEN")) D
.S DGOPT("GEN")=$P(^BDGPAR(1,0),U,5) ;Last attempt to get min age
;IHS/ITSC/WAR 12/16/03 end of mod
;
W @IOF,!!!?18,"DAY SURGERY STATISTICS BY SERVICE",!!
;***> get date range
BDATE S %DT="AEQ",%DT("A")="Select beginning date: ",X="" D ^%DT
G END:Y=-1 S DGBDT=Y
EDATE S %DT="AEQ",%DT("A")="Select ending date: ",X="" D ^%DT
G END:Y=-1 S DGEDT=Y
;
;***> get print device
S %ZIS="PQ" D ^%ZIS G END:POP,QUE:$D(IO("Q")) U IO G CALC
QUE K IO("Q") S ZTRTN="CALC^ADGDSST",ZTDESC="DAY SURGERY STATS"
;IHS/DSD/ENM 07/16/99 NEXT LINE COPIED/MOD
;S ZTSAVE("DGBDT")="",ZTSAVE("DGEDT")=""
F DGI="DGBDT","DGEDT","DGPV","DGOPT(""GEN"")","DGOPT(""QA"")","DGOPT(""QA1"")" S ZTSAVE(DGI)=""
D ^%ZTLOAD D ^%ZISC K ZTSK
END K Y,DGBDT,DGEDT D HOME^%ZIS Q
;
;
CALC ;***> sort by surgery date and find service and age
S DGDT=DGBDT-.9999
C1 S DGDT=$O(^ADGDS("AA",DGDT)) G PRINT:DGDT="",PRINT:DGDT>(DGEDT_.2400) S DFN=0
C2 S DFN=$O(^ADGDS("AA",DGDT,DFN)) G C1:DFN="" S DGN=0
C3 S DGN=$O(^ADGDS("AA",DGDT,DFN,DGN)) G C2:DGN=""
G C3:'$D(^ADGDS(DFN,"DS",DGN,0)) S DGSRV=$P(^(0),U,5)
I $D(^ADGDS(DFN,"DS",DGN,2)) G C3:$P(^(2),U,3)="Y" G C3:$P(^(2),U,4)="Y"
S:DGSRV'="" DGSRV=$S($D(^DIC(45.7,DGSRV,0)):$P(^(0),U),1:"")
S AGE=$$VAL^XBDIQ1(9000001,DFN,1102.99)
I AGE="" S ^TMP($J,"ERR",DFN)="Date of Birth missing or invalid" G C3
;IHS/ITSC/WAR 12/16/03 added $G to avoid undefined if the OLD DS
; varialbes were not able to be setup by the VAR^ADGVAR call
;I AGE'<$P(DGOPT("GEN"),U,5) S DGA(DGSRV,"A")=$S($D(DGA(DGSRV,"A")):DGA(DGSRV,"A")+1,1:1) S:'$D(DGA(DGSRV,"P")) DGA(DGSRV,"P")=0
I AGE'<$P($G(DGOPT("GEN")),U,5) S DGA(DGSRV,"A")=$S($D(DGA(DGSRV,"A")):DGA(DGSRV,"A")+1,1:1) S:'$D(DGA(DGSRV,"P")) DGA(DGSRV,"P")=0
E S DGA(DGSRV,"P")=$S($D(DGA(DGSRV,"P")):DGA(DGSRV,"P")+1,1:1) S:'$D(DGA(DGSRV,"A")) DGA(DGSRV,"A")=0
G C3
;
PRINT ;***> print
S DGFAC=$P(^DIC(4,DUZ(2),0),U),DGDUZ=$P(^VA(200,DUZ,0),U,2)
S (DGLIN,DGLIN1)="",$P(DGLIN,"-",80)="",$P(DGLIN1,"=",80)=""
;
S (DGSRV,DGPAGE)=0 D HEAD
P1 S DGSRV=$O(DGA(DGSRV)) G EXIT:DGSRV=""
W !?3,DGSRV W ?29,$J(DGA(DGSRV,"A"),3),?41,$J(DGA(DGSRV,"P"),3)
W ?63,$J(DGA(DGSRV,"A")+DGA(DGSRV,"P"),4) G P1
;
;***> print totals
EXIT W !,DGLIN,!!!?3,"TOTALS:"
S (DGX,DGY)=0 F S DGX=$O(DGA(DGX)) Q:DGX="" S DGY=DGY+DGA(DGX,"A")
S (DGX1,DGY1)=0
F S DGX1=$O(DGA(DGX1)) Q:DGX1="" S DGY1=DGY1+DGA(DGX1,"P")
W ?28,$J(DGY,4),?40,$J(DGY1,4),?63,$J((DGY+DGY1),4)
;
END1 ;***> eoj
I IOST["C-" D PRTOPT^ADGVAR
W @IOF D KILL^ADGUTIL D ^%ZISC Q
;
;
HEAD ;***> subrtn to print heading
I (IOST["C-")!(DGPAGE>0) W @IOF
W !,DGDUZ,?82-$L(DGFAC)\2,DGFAC S DGPAGE=DGPAGE+1
W ! D TIME^ADGUTIL W ?23,"DAY SURGERY STATISTICS BY SERVICE"
S DGX=$E(DGBDT,4,5)_"/"_$E(DGBDT,6,7)_"/"_($E(DGBDT,1,3)+1700)
S DGY=$E(DGEDT,4,5)_"/"_$E(DGEDT,6,7)_"/"_($E(DGEDT,1,3)+1700)
W !,$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3),?24,"from ",DGX," to ",DGY
W !!?5,"SERVICE",?29,"ADULT",?41,"PEDS",?57,"TOTAL FOR SERVICE"
W !,DGLIN1,! Q
ADGDSST ; IHS/ADC/PDW/ENM - DAY SURGERY STATISTICS BY SERVICE ; [ 12/16/2003 3:14 PM ]
+1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;**3**;MAR 25, 1999
+2 ;IHS/ITSC/WAR 12/16/03 Added call to 'old'(?) init of IHS variales
+3 IF '$DATA(DGOPT("GEN"))&($DATA(^DG(43,1,9999999)))
DO VAR^ADGVAR
+4 IF '$DATA(DGOPT("GEN"))
Begin DoDot:1
+5 ;Last attempt to get min age
SET DGOPT("GEN")=$PIECE(^BDGPAR(1,0),U,5)
End DoDot:1
+6 ;IHS/ITSC/WAR 12/16/03 end of mod
+7 ;
+8 WRITE @IOF,!!!?18,"DAY SURGERY STATISTICS BY SERVICE",!!
+9 ;***> get date range
BDATE SET %DT="AEQ"
SET %DT("A")="Select beginning date: "
SET X=""
DO ^%DT
+1 IF Y=-1
GOTO END
SET DGBDT=Y
EDATE SET %DT="AEQ"
SET %DT("A")="Select ending date: "
SET X=""
DO ^%DT
+1 IF Y=-1
GOTO END
SET DGEDT=Y
+2 ;
+3 ;***> get print device
+4 SET %ZIS="PQ"
DO ^%ZIS
IF POP
GOTO END
IF $DATA(IO("Q"))
GOTO QUE
USE IO
GOTO CALC
QUE KILL IO("Q")
SET ZTRTN="CALC^ADGDSST"
SET ZTDESC="DAY SURGERY STATS"
+1 ;IHS/DSD/ENM 07/16/99 NEXT LINE COPIED/MOD
+2 ;S ZTSAVE("DGBDT")="",ZTSAVE("DGEDT")=""
+3 FOR DGI="DGBDT","DGEDT","DGPV","DGOPT(""GEN"")","DGOPT(""QA"")","DGOPT(""QA1"")"
SET ZTSAVE(DGI)=""
+4 DO ^%ZTLOAD
DO ^%ZISC
KILL ZTSK
END KILL Y,DGBDT,DGEDT
DO HOME^%ZIS
QUIT
+1 ;
+2 ;
CALC ;***> sort by surgery date and find service and age
+1 SET DGDT=DGBDT-.9999
C1 SET DGDT=$ORDER(^ADGDS("AA",DGDT))
IF DGDT=""
GOTO PRINT
IF DGDT>(DGEDT_.2400)
GOTO PRINT
SET DFN=0
C2 SET DFN=$ORDER(^ADGDS("AA",DGDT,DFN))
IF DFN=""
GOTO C1
SET DGN=0
C3 SET DGN=$ORDER(^ADGDS("AA",DGDT,DFN,DGN))
IF DGN=""
GOTO C2
+1 IF '$DATA(^ADGDS(DFN,"DS",DGN,0))
GOTO C3
SET DGSRV=$PIECE(^(0),U,5)
+2 IF $DATA(^ADGDS(DFN,"DS",DGN,2))
IF $PIECE(^(2),U,3)="Y"
GOTO C3
IF $PIECE(^(2),U,4)="Y"
GOTO C3
+3 IF DGSRV'=""
SET DGSRV=$SELECT($DATA(^DIC(45.7,DGSRV,0)):$PIECE(^(0),U),1:"")
+4 SET AGE=$$VAL^XBDIQ1(9000001,DFN,1102.99)
+5 IF AGE=""
SET ^TMP($JOB,"ERR",DFN)="Date of Birth missing or invalid"
GOTO C3
+6 ;IHS/ITSC/WAR 12/16/03 added $G to avoid undefined if the OLD DS
+7 ; varialbes were not able to be setup by the VAR^ADGVAR call
+8 ;I AGE'<$P(DGOPT("GEN"),U,5) S DGA(DGSRV,"A")=$S($D(DGA(DGSRV,"A")):DGA(DGSRV,"A")+1,1:1) S:'$D(DGA(DGSRV,"P")) DGA(DGSRV,"P")=0
+9 IF AGE'<$PIECE($GET(DGOPT("GEN")),U,5)
SET DGA(DGSRV,"A")=$SELECT($DATA(DGA(DGSRV,"A")):DGA(DGSRV,"A")+1,1:1)
IF '$DATA(DGA(DGSRV,"P"))
SET DGA(DGSRV,"P")=0
+10 IF '$TEST
SET DGA(DGSRV,"P")=$SELECT($DATA(DGA(DGSRV,"P")):DGA(DGSRV,"P")+1,1:1)
IF '$DATA(DGA(DGSRV,"A"))
SET DGA(DGSRV,"A")=0
+11 GOTO C3
+12 ;
PRINT ;***> print
+1 SET DGFAC=$PIECE(^DIC(4,DUZ(2),0),U)
SET DGDUZ=$PIECE(^VA(200,DUZ,0),U,2)
+2 SET (DGLIN,DGLIN1)=""
SET $PIECE(DGLIN,"-",80)=""
SET $PIECE(DGLIN1,"=",80)=""
+3 ;
+4 SET (DGSRV,DGPAGE)=0
DO HEAD
P1 SET DGSRV=$ORDER(DGA(DGSRV))
IF DGSRV=""
GOTO EXIT
+1 WRITE !?3,DGSRV
WRITE ?29,$JUSTIFY(DGA(DGSRV,"A"),3),?41,$JUSTIFY(DGA(DGSRV,"P"),3)
+2 WRITE ?63,$JUSTIFY(DGA(DGSRV,"A")+DGA(DGSRV,"P"),4)
GOTO P1
+3 ;
+4 ;***> print totals
EXIT WRITE !,DGLIN,!!!?3,"TOTALS:"
+1 SET (DGX,DGY)=0
FOR
SET DGX=$ORDER(DGA(DGX))
IF DGX=""
QUIT
SET DGY=DGY+DGA(DGX,"A")
+2 SET (DGX1,DGY1)=0
+3 FOR
SET DGX1=$ORDER(DGA(DGX1))
IF DGX1=""
QUIT
SET DGY1=DGY1+DGA(DGX1,"P")
+4 WRITE ?28,$JUSTIFY(DGY,4),?40,$JUSTIFY(DGY1,4),?63,$JUSTIFY((DGY+DGY1),4)
+5 ;
END1 ;***> eoj
+1 IF IOST["C-"
DO PRTOPT^ADGVAR
+2 WRITE @IOF
DO KILL^ADGUTIL
DO ^%ZISC
QUIT
+3 ;
+4 ;
HEAD ;***> subrtn to print heading
+1 IF (IOST["C-")!(DGPAGE>0)
WRITE @IOF
+2 WRITE !,DGDUZ,?82-$LENGTH(DGFAC)\2,DGFAC
SET DGPAGE=DGPAGE+1
+3 WRITE !
DO TIME^ADGUTIL
WRITE ?23,"DAY SURGERY STATISTICS BY SERVICE"
+4 SET DGX=$EXTRACT(DGBDT,4,5)_"/"_$EXTRACT(DGBDT,6,7)_"/"_($EXTRACT(DGBDT,1,3)+1700)
+5 SET DGY=$EXTRACT(DGEDT,4,5)_"/"_$EXTRACT(DGEDT,6,7)_"/"_($EXTRACT(DGEDT,1,3)+1700)
+6 WRITE !,$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3),?24,"from ",DGX," to ",DGY
+7 WRITE !!?5,"SERVICE",?29,"ADULT",?41,"PEDS",?57,"TOTAL FOR SERVICE"
+8 WRITE !,DGLIN1,!
QUIT
