- 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
