- 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
