ADGDSQA ; IHS/ADC/PDW/ENM - DAY SURGERY PROVIDER QA REPORT ; [ 12/16/2003 4:06 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("QA1"))&($D(^DG(43,1,9999999.02))) D VAR^ADGVAR
;
W @IOF,!!!?28,"DAY SURGERY PROVIDER QA REPORT",!!
;***> 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
;
PROV ;***> select one or all providers
K DIR S DIR(0)="Y",DIR("A")="Print Report for ALL Providers"
S DIR("B")="NO",DIR("?")="Answer NO to print for only ONE provider"
D ^DIR S DGPV=Y G EDATE:$D(DUOUT),END:$D(DTOUT),END:$D(DIROUT)
ONE I Y=0 K DIR S DIR(0)="PO^6:EMQZ" D ^DIR
G PROV:$D(DIRUT),ONE:Y=-1 S DGPV=Y
;
;***> get print device
W !!,*7,"Report requires wide printer or condensed print.",!
S %ZIS="PQ" D ^%ZIS G END:POP,QUE:$D(IO("Q")) U IO G CALC
QUE K IO("Q") S ZTRTN="CALC^ADGDSQA",ZTDESC="DAY SURG PROV QA"
;F DGI="DGBDT","DGEDT","DGPV" S ZTSAVE(DGI)=""
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 ;***> Set up sorted utility file for date range
S DGDT=DGBDT-.0001,DGEDT=DGEDT+.2400 K ^TMP($J)
C1 S DGDT=$O(^ADGDS("AA",DGDT)) G NEXT:DGDT="",NEXT:DGDT>DGEDT S DFN=0
C2 S DFN=$O(^ADGDS("AA",DGDT,DFN)) G C1:DFN="" S DGDFN1=0
C3 S DGDFN1=$O(^ADGDS("AA",DGDT,DFN,DGDFN1)) G C2:DGDFN1=""
G C3:'$D(^ADGDS(DFN,0)),C3:'$D(^ADGDS(DFN,"DS",DGDFN1,0)) S DGSTR=^(0)
S (DGPRV,DGPRC,DGSRV,DGOBS,DGADM,DGADWK,DGNM,DGCMT)=""
S DGPRV=$P(DGSTR,U,6) I DGPV'=1,DGPRV'=+DGPV G C3 ;wrong provider
;
;***> check for sent to obs, admit
S DGSTR2=$G(^ADGDS(DFN,"DS",DGDFN1,2)),DGADM=$P(DGSTR2,U,2) ;admit?
S DGOBS=$P(DGSTR,U,7) G C4:DGADM="Y" ;obsrv?/skip next lines if admit
;
;***> check if admitted w/in time limit in site parameters
;IHS/ITSC/WAR 12/16/03 if parameter is not set - site never used DS -
; I added $G to DGOPT("QA1") as defensive code. Chk Q41 of the
; logged PIMS issues.
;S Y=9999999-DGDT,X1=$P(DGDT,"."),X2=$P(DGOPT("QA1"),U,2) D C^%DTC
S Y=9999999-DGDT,X1=$P(DGDT,"."),X2=$P($G(DGOPT("QA1")),U,2) D C^%DTC
S DGX=9999999-X
S DGX=$O(^DGPM("ATID1",DFN,DGX))
I DGX'="",DGX'>Y S DGADWK=9999999-DGX
;
C4 I (DGOBS="")&(DGADM="")&(DGADWK="") G C3
;
;***> set variables of data items to be printed
S DGCHT=$S($D(^AUPNPAT(DFN,41,DUZ(2),0)):$P(^(0),U,2),1:"??") ;chrt #
S DGPRC=$P(DGSTR,U,2),DGSRV=$P(DGSTR,U,5) ;procedure/service
S:DGSRV'="" DGSRV=$P($G(^DIC(45.7,DGSRV,0)),U)
S DGCMT=$P($G(DGSTR2),U,6) S DGNM=$P(^DPT(DFN,0),U) ;comment/patient
;
S ^TMP($J,$P(DGDT,"."),DGNM,DFN)=DGCHT_U_DGSRV_U_DGPRV_U_DGPRC_U_DGOBS_U_DGADM_U_DGADWK_U_DGCMT G C3
;
;***> go to print rtn
NEXT G ^ADGDSQA1
ADGDSQA ; IHS/ADC/PDW/ENM - DAY SURGERY PROVIDER QA REPORT ; [ 12/16/2003 4:06 PM ]
+1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;**3**;MAR 25, 1999
+2 ;
+3 ;IHS/ITSC/WAR 12/16/03 Added call to 'old'(?) init of IHS variales
+4 IF '$DATA(DGOPT("QA1"))&($DATA(^DG(43,1,9999999.02)))
DO VAR^ADGVAR
+5 ;
+6 WRITE @IOF,!!!?28,"DAY SURGERY PROVIDER QA REPORT",!!
+7 ;***> 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 ;
PROV ;***> select one or all providers
+1 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Print Report for ALL Providers"
+2 SET DIR("B")="NO"
SET DIR("?")="Answer NO to print for only ONE provider"
+3 DO ^DIR
SET DGPV=Y
IF $DATA(DUOUT)
GOTO EDATE
IF $DATA(DTOUT)
GOTO END
IF $DATA(DIROUT)
GOTO END
ONE IF Y=0
KILL DIR
SET DIR(0)="PO^6:EMQZ"
DO ^DIR
+1 IF $DATA(DIRUT)
GOTO PROV
IF Y=-1
GOTO ONE
SET DGPV=Y
+2 ;
+3 ;***> get print device
+4 WRITE !!,*7,"Report requires wide printer or condensed print.",!
+5 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^ADGDSQA"
SET ZTDESC="DAY SURG PROV QA"
+1 ;F DGI="DGBDT","DGEDT","DGPV" S ZTSAVE(DGI)=""
+2 FOR DGI="DGBDT","DGEDT","DGPV","DGOPT(""GEN"")","DGOPT(""QA"")","DGOPT(""QA1"")"
SET ZTSAVE(DGI)=""
+3 DO ^%ZTLOAD
DO ^%ZISC
KILL ZTSK
END KILL Y,DGBDT,DGEDT
DO HOME^%ZIS
QUIT
+1 ;
+2 ;
CALC ;***> Set up sorted utility file for date range
+1 SET DGDT=DGBDT-.0001
SET DGEDT=DGEDT+.2400
KILL ^TMP($JOB)
C1 SET DGDT=$ORDER(^ADGDS("AA",DGDT))
IF DGDT=""
GOTO NEXT
IF DGDT>DGEDT
GOTO NEXT
SET DFN=0
C2 SET DFN=$ORDER(^ADGDS("AA",DGDT,DFN))
IF DFN=""
GOTO C1
SET DGDFN1=0
C3 SET DGDFN1=$ORDER(^ADGDS("AA",DGDT,DFN,DGDFN1))
IF DGDFN1=""
GOTO C2
+1 IF '$DATA(^ADGDS(DFN,0))
GOTO C3
IF '$DATA(^ADGDS(DFN,"DS",DGDFN1,0))
GOTO C3
SET DGSTR=^(0)
+2 SET (DGPRV,DGPRC,DGSRV,DGOBS,DGADM,DGADWK,DGNM,DGCMT)=""
+3 ;wrong provider
SET DGPRV=$PIECE(DGSTR,U,6)
IF DGPV'=1
IF DGPRV'=+DGPV
GOTO C3
+4 ;
+5 ;***> check for sent to obs, admit
+6 ;admit?
SET DGSTR2=$GET(^ADGDS(DFN,"DS",DGDFN1,2))
SET DGADM=$PIECE(DGSTR2,U,2)
+7 ;obsrv?/skip next lines if admit
SET DGOBS=$PIECE(DGSTR,U,7)
IF DGADM="Y"
GOTO C4
+8 ;
+9 ;***> check if admitted w/in time limit in site parameters
+10 ;IHS/ITSC/WAR 12/16/03 if parameter is not set - site never used DS -
+11 ; I added $G to DGOPT("QA1") as defensive code. Chk Q41 of the
+12 ; logged PIMS issues.
+13 ;S Y=9999999-DGDT,X1=$P(DGDT,"."),X2=$P(DGOPT("QA1"),U,2) D C^%DTC
+14 SET Y=9999999-DGDT
SET X1=$PIECE(DGDT,".")
SET X2=$PIECE($GET(DGOPT("QA1")),U,2)
DO C^%DTC
+15 SET DGX=9999999-X
+16 SET DGX=$ORDER(^DGPM("ATID1",DFN,DGX))
+17 IF DGX'=""
IF DGX'>Y
SET DGADWK=9999999-DGX
+18 ;
C4 IF (DGOBS="")&(DGADM="")&(DGADWK="")
GOTO C3
+1 ;
+2 ;***> set variables of data items to be printed
+3 ;chrt #
SET DGCHT=$SELECT($DATA(^AUPNPAT(DFN,41,DUZ(2),0)):$PIECE(^(0),U,2),1:"??")
+4 ;procedure/service
SET DGPRC=$PIECE(DGSTR,U,2)
SET DGSRV=$PIECE(DGSTR,U,5)
+5 IF DGSRV'=""
SET DGSRV=$PIECE($GET(^DIC(45.7,DGSRV,0)),U)
+6 ;comment/patient
SET DGCMT=$PIECE($GET(DGSTR2),U,6)
SET DGNM=$PIECE(^DPT(DFN,0),U)
+7 ;
+8 SET ^TMP($JOB,$PIECE(DGDT,"."),DGNM,DFN)=DGCHT_U_DGSRV_U_DGPRV_U_DGPRC_U_DGOBS_U_DGADM_U_DGADWK_U_DGCMT
GOTO C3
+9 ;
+10 ;***> go to print rtn
NEXT GOTO ^ADGDSQA1
