ADGDSQA1 ; IHS/ADC/PDW/ENM - DAY SURGERY PROVIDER QA REPORT PRINT ; [ 03/25/1999 11:48 AM ]
;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
;
;***> initialize variables
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
S (DGPRV,DGPRC,DGCNT,DGOBS,DGADM,DGADWK,DGCHT)="",DGDT=0
;
;***> step thru utility file for sorted data
A1 S DGDT=$O(^TMP($J,DGDT)) G TOTAL:DGDT="" S DGNM=0
A2 S DGNM=$O(^TMP($J,DGDT,DGNM)) G A1:DGNM="" S DFN=0
A3 S DFN=$O(^TMP($J,DGDT,DGNM,DFN)) G A2:DFN="" S DGSTR=^(DFN)
;
;chart #/service/provider
S DGCHT=$P(DGSTR,U),DGSRV=$P(DGSTR,U,2),DGPRV=$P(DGSTR,U,3)
;procedure/los on obsrv/admitted?
S DGPRC=$P(DGSTR,U,4),DGOBS=$P(DGSTR,U,5),DGADM=$P(DGSTR,U,6)
;admitted w/in limit/comments/increment count
S DGADWK=$P(DGSTR,U,7),DGCMT=$P(DGSTR,U,8),DGCNT=DGCNT+1
;
PRINT ;***> print line of data
W !,$E(DGDT,4,5)_"/"_$E(DGDT,6,7)_"/"_$E(DGDT,2,3),?11,$E(DGNM,1,20)
W ?34,DGCHT,?41,$E(DGSRV,1,3)
W:DGPRV'="" ?47,$S($D(^VA(200,DGPRV,0)):$E($P(^(0),U),1,20),1:"??")
W ?70,$E(DGPRC,1,25),?100,$S(DGOBS="":"",1:"OBS ")
W ?100,$S(DGADM="":"",1:"ADMIT")
W ?100,$S(DGADWK="":"",1:"ADM W/IN WEEK")
W ?115,DGCMT
I $Y>(IOSL-8) D NEWPG G END1:DGSTOP=U
G A3
;
;***> print total
TOTAL W !!,DGLIN1,!?5,"TOTAL PATIENTS: ",+DGCNT
;
END ;***> eoj
I IOST["C-" D PRTOPT^ADGVAR
END1 W @IOF S X=DGZRM X ^%ZOSF("RM")
D KILL^ADGUTIL K ^TMP($J) 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'=U D HEAD
Q
;
HEAD ;***> subrtn to print heading
I (IOST["C-")!(DGPAGE>0) W @IOF
S DGPAGE=DGPAGE+1
W ?11,"*****Confidential Patient Data Covered by Privacy Act*****"
W !,DGDUZ,?132-$L(DGFAC)\2,DGFAC,?125,"Page ",DGPAGE
W ! D TIME^ADGUTIL W ?49,"DAY SURGERY PROVIDER QA REPORT"
S Y=DT D DD^%DT W !,Y,?48,DGDTLIN,!
W !,"DATE",?11,"PATIENT",?34,"HRCN",?41,"SRV",?47,"PROVIDER"
W ?70,"PROCEDURE",?100,"ACTION",?117,"COMMENTS",!,DGLIN
Q
ADGDSQA1 ; IHS/ADC/PDW/ENM - DAY SURGERY PROVIDER QA REPORT PRINT ; [ 03/25/1999 11:48 AM ]
+1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
+2 ;
+3 ;***> initialize variables
+4 ;facility name/page #
SET DGFAC=$PIECE(^DIC(4,DUZ(2),0),U)
SET DGPAGE=0
+5 ;user's initials
SET DGDUZ=$PIECE(^VA(200,DUZ,0),U,2)
+6 ;lines
SET (DGLIN,DGLIN1)=""
SET $PIECE(DGLIN,"=",132)=""
SET $PIECE(DGLIN1,"-",132)=""
+7 SET Y=DGBDT
DO DD^%DT
SET DGX=Y
SET Y=DGEDT-.2400
DO DD^%DT
SET DGY=Y
+8 ;date range line set
SET DGDTLIN="from "_DGX_" to "_DGY
+9 SET X=132
SET DGZRM=IOM
XECUTE ^%ZOSF("RM")
DO HEAD
+10 SET (DGPRV,DGPRC,DGCNT,DGOBS,DGADM,DGADWK,DGCHT)=""
SET DGDT=0
+11 ;
+12 ;***> step thru utility file for sorted data
A1 SET DGDT=$ORDER(^TMP($JOB,DGDT))
IF DGDT=""
GOTO TOTAL
SET DGNM=0
A2 SET DGNM=$ORDER(^TMP($JOB,DGDT,DGNM))
IF DGNM=""
GOTO A1
SET DFN=0
A3 SET DFN=$ORDER(^TMP($JOB,DGDT,DGNM,DFN))
IF DFN=""
GOTO A2
SET DGSTR=^(DFN)
+1 ;
+2 ;chart #/service/provider
+3 SET DGCHT=$PIECE(DGSTR,U)
SET DGSRV=$PIECE(DGSTR,U,2)
SET DGPRV=$PIECE(DGSTR,U,3)
+4 ;procedure/los on obsrv/admitted?
+5 SET DGPRC=$PIECE(DGSTR,U,4)
SET DGOBS=$PIECE(DGSTR,U,5)
SET DGADM=$PIECE(DGSTR,U,6)
+6 ;admitted w/in limit/comments/increment count
+7 SET DGADWK=$PIECE(DGSTR,U,7)
SET DGCMT=$PIECE(DGSTR,U,8)
SET DGCNT=DGCNT+1
+8 ;
PRINT ;***> print line of data
+1 WRITE !,$EXTRACT(DGDT,4,5)_"/"_$EXTRACT(DGDT,6,7)_"/"_$EXTRACT(DGDT,2,3),?11,$EXTRACT(DGNM,1,20)
+2 WRITE ?34,DGCHT,?41,$EXTRACT(DGSRV,1,3)
+3 IF DGPRV'=""
WRITE ?47,$SELECT($DATA(^VA(200,DGPRV,0)):$EXTRACT($PIECE(^(0),U),1,20),1:"??")
+4 WRITE ?70,$EXTRACT(DGPRC,1,25),?100,$SELECT(DGOBS="":"",1:"OBS ")
+5 WRITE ?100,$SELECT(DGADM="":"",1:"ADMIT")
+6 WRITE ?100,$SELECT(DGADWK="":"",1:"ADM W/IN WEEK")
+7 WRITE ?115,DGCMT
+8 IF $Y>(IOSL-8)
DO NEWPG
IF DGSTOP=U
GOTO END1
+9 GOTO A3
+10 ;
+11 ;***> print total
TOTAL WRITE !!,DGLIN1,!?5,"TOTAL PATIENTS: ",+DGCNT
+1 ;
END ;***> eoj
+1 IF IOST["C-"
DO PRTOPT^ADGVAR
END1 WRITE @IOF
SET X=DGZRM
XECUTE ^%ZOSF("RM")
+1 DO KILL^ADGUTIL
KILL ^TMP($JOB)
DO ^%ZISC
QUIT
+2 ;
+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'=U
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 ?11,"*****Confidential Patient Data Covered by Privacy Act*****"
+4 WRITE !,DGDUZ,?132-$LENGTH(DGFAC)\2,DGFAC,?125,"Page ",DGPAGE
+5 WRITE !
DO TIME^ADGUTIL
WRITE ?49,"DAY SURGERY PROVIDER QA REPORT"
+6 SET Y=DT
DO DD^%DT
WRITE !,Y,?48,DGDTLIN,!
+7 WRITE !,"DATE",?11,"PATIENT",?34,"HRCN",?41,"SRV",?47,"PROVIDER"
+8 WRITE ?70,"PROCEDURE",?100,"ACTION",?117,"COMMENTS",!,DGLIN
+9 QUIT
