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
