- 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
