- ADGDSAU1 ; IHS/ADC/PDW/ENM - DAY SURGERY AUDIT REPORT PRINT ; [ 03/25/1999 11:48 AM ]
- ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
- ;
- ;***> initialize variables
- S (AGE,DGPRC,DGCNT,DGLOS,DGOBS,DGADM,DGADWK,DGCAN,DGCHT)=""
- S (DGDT,DGCCNT,DGWCNT,DGADCNT,DGACNT,DGNCNT,DGOCNT)=0
- S DGFAC=$P(^DIC(4,DUZ(2),0),U),DGPAGE=0 ;facility name/page #
- S DGDUZ=$P(^VA(200,DUZ,0),U,2) ;user's initials
- S (DGLIN,DGLIN1)="",$P(DGLIN,"=",132)="",$P(DGLIN1,"-",132)="" ;lines
- S Y=DGBDT D DD^%DT S DGX=Y S Y=DGEDT-.2400 D DD^%DT S DGY=Y
- S DGDTLIN="from "_DGX_" to "_DGY ;date range line set
- S X=132,DGZRM=IOM X ^%ZOSF("RM") D HEAD ;set margin/print heading
- ;
- ;***> step thru sorted list then print
- A1 S DGDT=$O(^TMP("DGDSAU",$J,DGDT)) G TOTALS:DGDT="" S DGSRV=0
- A2 S DGSRV=$O(^TMP("DGDSAU",$J,DGDT,DGSRV)) G A1:DGSRV="" S DGNM=0
- A3 S DGNM=$O(^TMP("DGDSAU",$J,DGDT,DGSRV,DGNM)) G A2:DGNM="" S DFN=0
- A3A S DFN=$O(^TMP("DGDSAU",$J,DGDT,DGSRV,DGNM,DFN)) G A3:DFN="" S DGDFN1=0
- A4 S DGDFN1=$O(^TMP("DGDSAU",$J,DGDT,DGSRV,DGNM,DFN,DGDFN1)) G A3A:DGDFN1=""
- ;
- S DGSTR=^TMP("DGDSAU",$J,DGDT,DGSRV,DGNM,DFN,DGDFN1)
- S DGCHT=$P(DGSTR,"^"),AGE=$P(DGSTR,"^",2) ;chrt #/age
- S DGPRC=$P(DGSTR,"^",3),DGLOS=$P(DGSTR,"^",4) ;proc/length of stay
- ;sent to observ?/admitted? directly?/admitted w/in a week?
- S DGOBS=$P(DGSTR,"^",5),DGADM=$P(DGSTR,"^",6),DGADWK=$P(DGSTR,"^",7)
- S:DGADM'="" DGADCNT=DGADCNT+1 S:DGADWK'="" DGWCNT=DGWCNT+1 ;counts
- S:DGOBS>0 DGOCNT=DGOCNT+1 S DGCAN=$P(DGSTR,"^",8) ;obsv cnt/cancel?
- S DGUNES=$P(DGSTR,"^",9),DGNS=$P(DGSTR,"^",10) ;unescorted?/no-show?
- S DGCMT=$P(DGSTR,"^",11),DGCNT=DGCNT+1 ;comments/count
- ;
- PRINT ;***> print line
- W !,$E(DGDT,4,5)_"/"_$E(DGDT,6,7)_"/"_$E(DGDT,2,3),?11,$E(DGNM,1,20)
- W ?34,DGCHT,?41,AGE,?46,$E(DGSRV,1,3),?52,$E(DGPRC,1,20)
- W ?75,$J(DGLOS,5),?82,$J(DGOBS,5),?91,DGUNES
- S:DGUNES="Y" DGACNT=DGACNT+1
- W ?97,$S(+DGADM=DGADM:"Y",1:DGADM)
- W:DGADWK'="" ?105,$E(DGADWK,4,5)_"/"_$E(DGADWK,6,7)
- I DGCAN="Y" W ?114,"C" S DGCCNT=DGCCNT+1
- I DGNS="Y" W ?114,"N" S DGNCNT=DGNCNT+1
- W ?120,DGCMT
- I $Y>(IOSL-8) D NEWPG G END:DGSTOP=U
- G A4
- ;
- ;***> print totals
- TOTALS W !!,DGLIN1,!?5,"TOTAL PATIENTS: ",DGCNT I $Y>(IOSL-9) D NEWPG
- W !!?65,"TOTAL SENT TO OBS",?85,DGOCNT
- W !?65,"TOTAL UNESCORTED",?90,DGACNT
- W !?65,"TOTAL ADMITTED FROM DS",?99,DGADCNT
- W !?65,"TOTAL ADMITTED W/IN WEEK",?106,DGWCNT
- W !?65,"TOTAL CANCELLED",?114,DGCCNT
- W !?65,"TOTAL NO-SHOWS",?114,DGNCNT
- I IOST["C-" D
- . K DIR S DIR(0)="E"
- . S DIR("A")="End of Report; Press RETURN to continue" D ^DIR
- ;
- END ;***> eoj
- W @IOF S X=DGZRM X ^%ZOSF("RM") K DGZRM
- D KILL^ADGUTIL D ^%ZISC Q
- ;
- NEWPG ;***> subrtn for end of page control
- I IOST'?1"C-".E D HEAD S DGSTOP="" Q
- I DGPAGE>0 K DIR S DIR(0)="E" D ^DIR S DGSTOP=X
- I DGSTOP'="^" D HEAD
- Q
- ;
- HEAD ;***> subrtn to print heading
- I (IOST["C-")!(DGPAGE>0) W @IOF
- S DGPAGE=DGPAGE+1
- W ?37,"*****Confidential Patient Data Covered by Privacy Act*****",!
- W DGDUZ,?132-$L(DGFAC)\2,DGFAC,?125,"Page ",DGPAGE
- W ! D TIME^ADGUTIL W ?52,"DAY SURGERY AUDIT REPORT"
- S Y=DT D DD^%DT W !,Y,?48,DGDTLIN
- W !!?98,"ADMITTED",?112,"CANCEL"
- W !,"SURGERY",?77,"LOS",?83,"OBSV",?96,"FROM",?104,"W/IN"
- W ?113,"OR",?120,"POST-OP",!,"DATE",?11,"PATIENT",?34,"HRCN"
- W ?41,"AGE",?47,"SRV",?52,"PROCEDURE",?77,"HRS",?83,"LOS"
- W ?89,"UNESC",?97,"DS",?104,"WEEK",?112,"NOSHOW",?120,"COMMENTS"
- W !,DGLIN,!! Q
- Q
- ADGDSAU1 ; IHS/ADC/PDW/ENM - DAY SURGERY AUDIT REPORT PRINT ; [ 03/25/1999 11:48 AM ]
- +1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
- +2 ;
- +3 ;***> initialize variables
- +4 SET (AGE,DGPRC,DGCNT,DGLOS,DGOBS,DGADM,DGADWK,DGCAN,DGCHT)=""
- +5 SET (DGDT,DGCCNT,DGWCNT,DGADCNT,DGACNT,DGNCNT,DGOCNT)=0
- +6 ;facility name/page #
- SET DGFAC=$PIECE(^DIC(4,DUZ(2),0),U)
- SET DGPAGE=0
- +7 ;user's initials
- SET DGDUZ=$PIECE(^VA(200,DUZ,0),U,2)
- +8 ;lines
- SET (DGLIN,DGLIN1)=""
- SET $PIECE(DGLIN,"=",132)=""
- SET $PIECE(DGLIN1,"-",132)=""
- +9 SET Y=DGBDT
- DO DD^%DT
- SET DGX=Y
- SET Y=DGEDT-.2400
- DO DD^%DT
- SET DGY=Y
- +10 ;date range line set
- SET DGDTLIN="from "_DGX_" to "_DGY
- +11 ;set margin/print heading
- SET X=132
- SET DGZRM=IOM
- XECUTE ^%ZOSF("RM")
- DO HEAD
- +12 ;
- +13 ;***> step thru sorted list then print
- A1 SET DGDT=$ORDER(^TMP("DGDSAU",$JOB,DGDT))
- IF DGDT=""
- GOTO TOTALS
- SET DGSRV=0
- A2 SET DGSRV=$ORDER(^TMP("DGDSAU",$JOB,DGDT,DGSRV))
- IF DGSRV=""
- GOTO A1
- SET DGNM=0
- A3 SET DGNM=$ORDER(^TMP("DGDSAU",$JOB,DGDT,DGSRV,DGNM))
- IF DGNM=""
- GOTO A2
- SET DFN=0
- A3A SET DFN=$ORDER(^TMP("DGDSAU",$JOB,DGDT,DGSRV,DGNM,DFN))
- IF DFN=""
- GOTO A3
- SET DGDFN1=0
- A4 SET DGDFN1=$ORDER(^TMP("DGDSAU",$JOB,DGDT,DGSRV,DGNM,DFN,DGDFN1))
- IF DGDFN1=""
- GOTO A3A
- +1 ;
- +2 SET DGSTR=^TMP("DGDSAU",$JOB,DGDT,DGSRV,DGNM,DFN,DGDFN1)
- +3 ;chrt #/age
- SET DGCHT=$PIECE(DGSTR,"^")
- SET AGE=$PIECE(DGSTR,"^",2)
- +4 ;proc/length of stay
- SET DGPRC=$PIECE(DGSTR,"^",3)
- SET DGLOS=$PIECE(DGSTR,"^",4)
- +5 ;sent to observ?/admitted? directly?/admitted w/in a week?
- +6 SET DGOBS=$PIECE(DGSTR,"^",5)
- SET DGADM=$PIECE(DGSTR,"^",6)
- SET DGADWK=$PIECE(DGSTR,"^",7)
- +7 ;counts
- IF DGADM'=""
- SET DGADCNT=DGADCNT+1
- IF DGADWK'=""
- SET DGWCNT=DGWCNT+1
- +8 ;obsv cnt/cancel?
- IF DGOBS>0
- SET DGOCNT=DGOCNT+1
- SET DGCAN=$PIECE(DGSTR,"^",8)
- +9 ;unescorted?/no-show?
- SET DGUNES=$PIECE(DGSTR,"^",9)
- SET DGNS=$PIECE(DGSTR,"^",10)
- +10 ;comments/count
- SET DGCMT=$PIECE(DGSTR,"^",11)
- SET DGCNT=DGCNT+1
- +11 ;
- PRINT ;***> print line
- +1 WRITE !,$EXTRACT(DGDT,4,5)_"/"_$EXTRACT(DGDT,6,7)_"/"_$EXTRACT(DGDT,2,3),?11,$EXTRACT(DGNM,1,20)
- +2 WRITE ?34,DGCHT,?41,AGE,?46,$EXTRACT(DGSRV,1,3),?52,$EXTRACT(DGPRC,1,20)
- +3 WRITE ?75,$JUSTIFY(DGLOS,5),?82,$JUSTIFY(DGOBS,5),?91,DGUNES
- +4 IF DGUNES="Y"
- SET DGACNT=DGACNT+1
- +5 WRITE ?97,$SELECT(+DGADM=DGADM:"Y",1:DGADM)
- +6 IF DGADWK'=""
- WRITE ?105,$EXTRACT(DGADWK,4,5)_"/"_$EXTRACT(DGADWK,6,7)
- +7 IF DGCAN="Y"
- WRITE ?114,"C"
- SET DGCCNT=DGCCNT+1
- +8 IF DGNS="Y"
- WRITE ?114,"N"
- SET DGNCNT=DGNCNT+1
- +9 WRITE ?120,DGCMT
- +10 IF $Y>(IOSL-8)
- DO NEWPG
- IF DGSTOP=U
- GOTO END
- +11 GOTO A4
- +12 ;
- +13 ;***> print totals
- TOTALS WRITE !!,DGLIN1,!?5,"TOTAL PATIENTS: ",DGCNT
- IF $Y>(IOSL-9)
- DO NEWPG
- +1 WRITE !!?65,"TOTAL SENT TO OBS",?85,DGOCNT
- +2 WRITE !?65,"TOTAL UNESCORTED",?90,DGACNT
- +3 WRITE !?65,"TOTAL ADMITTED FROM DS",?99,DGADCNT
- +4 WRITE !?65,"TOTAL ADMITTED W/IN WEEK",?106,DGWCNT
- +5 WRITE !?65,"TOTAL CANCELLED",?114,DGCCNT
- +6 WRITE !?65,"TOTAL NO-SHOWS",?114,DGNCNT
- +7 IF IOST["C-"
- Begin DoDot:1
- +8 KILL DIR
- SET DIR(0)="E"
- +9 SET DIR("A")="End of Report; Press RETURN to continue"
- DO ^DIR
- End DoDot:1
- +10 ;
- END ;***> eoj
- +1 WRITE @IOF
- SET X=DGZRM
- XECUTE ^%ZOSF("RM")
- KILL DGZRM
- +2 DO KILL^ADGUTIL
- DO ^%ZISC
- QUIT
- +3 ;
- NEWPG ;***> subrtn for end of page control
- +1 IF IOST'?1"C-".E
- DO HEAD
- SET DGSTOP=""
- QUIT
- +2 IF DGPAGE>0
- KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- SET DGSTOP=X
- +3 IF DGSTOP'="^"
- DO HEAD
- +4 QUIT
- +5 ;
- HEAD ;***> subrtn to print heading
- +1 IF (IOST["C-")!(DGPAGE>0)
- WRITE @IOF
- +2 SET DGPAGE=DGPAGE+1
- +3 WRITE ?37,"*****Confidential Patient Data Covered by Privacy Act*****",!
- +4 WRITE DGDUZ,?132-$LENGTH(DGFAC)\2,DGFAC,?125,"Page ",DGPAGE
- +5 WRITE !
- DO TIME^ADGUTIL
- WRITE ?52,"DAY SURGERY AUDIT REPORT"
- +6 SET Y=DT
- DO DD^%DT
- WRITE !,Y,?48,DGDTLIN
- +7 WRITE !!?98,"ADMITTED",?112,"CANCEL"
- +8 WRITE !,"SURGERY",?77,"LOS",?83,"OBSV",?96,"FROM",?104,"W/IN"
- +9 WRITE ?113,"OR",?120,"POST-OP",!,"DATE",?11,"PATIENT",?34,"HRCN"
- +10 WRITE ?41,"AGE",?47,"SRV",?52,"PROCEDURE",?77,"HRS",?83,"LOS"
- +11 WRITE ?89,"UNESC",?97,"DS",?104,"WEEK",?112,"NOSHOW",?120,"COMMENTS"
- +12 WRITE !,DGLIN,!!
- QUIT
- +13 QUIT
