IBOMHC ;SAB/EDE - COMPACT ACT COPAY Review Report ;JUL 12 2021
;;2.0;INTEGRATED BILLING;**709,720,736,772**;21-MAR-94;Build 6
;;Per VA Directive 6402, this routine should not be modified.
;
; Reference to $$CODEC^ICDEX in ICR #5747
; Reference to $$RX^PSO52API in ICR #4820
; Reference to $$GETCPT^SDOE in ICR #2546
; Reference to $$RXSITE^PSOBPSUT in ICR #4701
; Reference to FILE #405 in ICR #419
; Reference to FILE #40.8 in ICR #417
;
EN ;
;
N IBSTART,IBEND,IBEXCEL,IBSTOP,IBSD,VAUTD
N POP,ZTDESC,ZTRTN,ZTSAVE,ZTSK,%ZIS
;Initialze Date fields
S (IBSTART,IBEND)="",IBSTOP=0
;Get the start and end dates.
D DATESEL(.IBSTART,.IBEND,"Date Copay Billed")
Q:IBSTOP
;Ask to sort by Division or not
S IBSD=$$GETDIV()
Q:IBSD<0 ;User requested an exit
;
W !!,"** This report can take a while to run and may be queued to run after hours. **",!
W !,"Note: Copay displays only if at least one COMPACT diagnosis is hit.",!
; export to Excel?
S IBEXCEL=$$GETEXCEL^IBUCMM() I IBEXCEL<0 Q
I IBEXCEL D PRTEXCEL^IBUCMM()
W:'IBEXCEL !!,"Report requires 132 columns.",! ; IB*2.0*720
;
; ask for device
K IOP,IO("Q")
S %ZIS="MQ",%ZIS("B")="",POP=0 D ^%ZIS Q:POP
I $D(IO("Q")) D Q ; queued report: ask if print queue should be cleared, then queue task
.S ZTDESC="COMPACT ACT Copay Review Report Report"
.S ZTRTN="MAIN^IBOMHC"
.S ZTSAVE("IBSTART")=IBSTART,ZTSAVE("IBEXCEL")=IBEXCEL,ZTSAVE("IBEND")=IBEND,ZTSAVE("VAUTD")="",ZTSAVE("VAUTD(")="",ZTSAVE("ZTREQ")="@"
.S ZTSAVE("IBSD")=IBSD
.D ^%ZTLOAD,HOME^%ZIS
.I $G(ZTSK) W !!,"Report compilation has started with task# ",ZTSK,".",!
.Q
;
D MAIN
Q
;
MAIN ; Main routine to gather and print the report
;
K ^TMP($J,"IBOMHC"),^TMP($J,"IBOMHCDX")
D COLLECT
D PRINT(IBSTART,IBEND)
Q
;
DATESEL(DATESTRT,DATEEND,DESCR) ; prompt for start and end dates
;
; sets DATESTRT and DATEEND vars to start date and end date respectively, sets IBSTOP=1 on user exit
;
N DIR,DUOUT,DTOUT,DIRUT,X,Y
N CADT,DT7
S CADT=$P($G(^IBE(350.9,1,71)),U,2) ; COMPACT ACT Benefit start date from 350.9/71.02
S DT7=$$FMADD^XLFDT(DT,-7) ; today's date - 7 days
S DIR(0)="DA^"_CADT_":"_DT_":EX"
S DIR("A")="Start with "_$S($G(DESCR)'="":DESCR_" ",1:"")_": "
S DIR("B")=$$FMTE^XLFDT($S(DT7<CADT:CADT,1:DT7),"1D")
S DIR("?",1)=" Please enter a valid start date."
S DIR("?",2)=" This date must not be in the future."
S DIR("?")=" It also may not precede COMPACT ACT Benefit start date ("_$$FMTE^XLFDT(CADT)_")"
D ^DIR
I $D(DIRUT) S IBSTOP=1 G DATESELX
S DATESTRT=Y
; End date
DATESEL1 ;
S DIR("A")=" End with "_$S($G(DESCR)'="":DESCR_" ",1:"")_": "
S DIR("B")=$$FMTE^XLFDT($$FMADD^XLFDT(DT),"1D")
S DIR("?",1)=" Please enter a valid end date."
S DIR("?")=" This date must not precede the start date entered above."
D ^DIR
I $D(DIRUT) S IBSTOP=1 G DATESELX
I Y<DATESTRT W !," End Date must not precede the Start Date." G DATESEL1
S DATEEND=Y
W !?5,"*** Selected date range from ",$$FMTE^XLFDT(DATESTRT)," to ",$$FMTE^XLFDT(DATEEND)," ***"
;
DATESELX ; dates prompt exit point
Q
;
COLLECT ; review the copays in the specified period for possible COMPACT Act related copays to review
;
N IBERROR,IBN,IBDXARY,IBPTF,IBDATA,IBLP,IBBLNO,IBCT,VADM,IBPM,IBPCE,IBRX,IBVADM,I,IBCPT,IBDIV,IBADM ; IB*2.0*720
N DFN,DONE,IBBDSC,IBCHTYPE,IBCHRG,IBDOS,IBNM,IBRF,IBRFFL,IBDATA1,IBLPDT,IBSTATNM,IBSTAT,IBSTABR
S IBCT=0
S IBLPDT=IBSTART-.001,IBEND=IBEND+.999999
;Load list of possible DXs into a TMP array
D GETDX
F S IBLPDT=$O(^IB("D",IBLPDT)) Q:'IBLPDT Q:IBLPDT>IBEND D
.S IBLP=0
.;Loop through file #350 using the Date Billed field within the Start and end Period
.F S IBLP=$O(^IB("D",IBLPDT,IBLP)) Q:'IBLP D
..;kill and re-init arrays
..K IBDXARY,IBCPTARY,VADM
..S IBDXARY="",IBCPTARY=""
..; Get Copay Data
..S IBDATA=$G(^IB(IBLP,0)),IBDATA1=$G(^IB(IBLP,1))
..S IBSTATNM=$$GET1^DIQ(350,IBLP_",",.05,"E") I "^BILLED^HOLD - RATE^HOLD - REVIEW^ON HOLD^"'[(U_IBSTATNM_U) Q
..S DFN=$P(IBDATA,U,2) I '$$ISELIG(DFN) Q
..;Extract field (.04)[RESULTING FROM]
..S IBRF=$P(IBDATA,U,4)
..;If no file number or ":" in field, skip and go to the next.
..Q:IBRF'[":"
..;Extract the file from the 1st ":" piece
..S IBRFFL=$P(IBRF,":")
..;If the copay is a RX copay, quit.
..Q:$$GET1^DIQ(350.1,$P(IBDATA,U,3)_",",.11,"I")=5
..;Extract date of service
..S IBDOS="" S:IBRFFL'=52 IBDOS=$P(IBDATA,U,14) ; IB*2.0*772
..Q:'IBDOS
..; Check division IB*2.0*720
..S IBDIV=""
..I IBRFFL=405 S IBDIV=$$INP^IBJDF2($P(IBRF,":",2))
..I IBRFFL=45 S IBADM=$O(^DGPM("APTF",$P(IBRF,":",2),0)) S:IBADM IBDIV=$$INP^IBJDF2(IBADM)
..I IBRFFL=409.68 S IBDIV=$$OPT^IBJDF2(IBDOS,DFN)
..S:IBDIV="" IBDIV=+$$PRIM^VASITE()
..I IBSD,'VAUTD Q:'$D(VAUTD(IBDIV)) ; quit if not a selected division.
..;
..D DEM^VADPT M IBVADM=VADM ; IB*2.0*720 moved line from above
..S IBNM=IBVADM(1),IBCHTYPE=$P(IBDATA,U,3) Q:IBCHTYPE="" Q:$D(^TMP($J,"IBOMHC","IDX",IBNM,IBDOS,IBCHTYPE)) ; IB*2.0*720
..Q:$$GET1^DIQ(350.1,IBCHTYPE,.05,"E")'="NEW"
..;If file is 45 (PTF), lookup the primary and Secondary diagnoses
..I IBRFFL=45 S IBPTF=$P(IBRF,":",2) D GETPTFDX(IBPTF,.IBDXARY)
..;If file is 409.68, lookup the diagnoses using OPTDX^IBCSC4D
..I IBRFFL=409.68 S IBPCE=$P(IBRF,":",2) D GETPCEDX(IBPCE,.IBDXARY),GETPCECP(IBPCE,.IBCPTARY)
..;If file is 405, grab the PTF or Diagnoses Text Strings.
..I IBRFFL=405 S IBPM=$P(IBRF,":",2) D GETPMDX(IBPM,.IBDXARY)
..;If file is 52, look the prescription to get the diagnosis associated with it
..S IBID=$E(IBVADM(1),1)_$P($P(IBVADM(2),U,2),"-",3)
..S IBSTAT=$P(IBDATA,U,5)
..I IBSTATNM["HOLD" S IBSTABR="HOLD"
..I IBSTATNM'["HOLD" S IBSTABR=$E($$GET1^DIQ(350.21,IBSTAT_",",.03,"E"),1,4)
..S IBBDSC=$E($$GET1^DIQ(350.1,IBCHTYPE,.01,"E"),1,12)
..S IBCHRG=$P(IBDATA,U,7),IBBLNO=$P(IBDATA,U,11)
..S DONE=0,I="" F S I=$O(IBDXARY(I)) Q:I="" D Q:DONE
...I I'="UNK",'$$CMPDX(I,.IBCPTARY),'$D(IBCPTARY("T2034")) Q
...S DONE=1
...I $D(IBCPTARY)<10!(I'="R45.851") D ;No CPT Codes Extracted or Dx is not R45.851 IB*2.0*720
....Q:'$$CMPDX(I,.IBCPTARY) ;T2034 visit only, so process this below.
....S IBCT=IBCT+1
....S ^TMP($J,"IBOMHC",IBCT)=IBNM_U_IBID_U_IBBLNO_U_IBSTABR_U_IBBDSC_U_$$FMTE^XLFDT(IBDOS,9)_U_$S(I="UNK":"",1:I)_U_U_IBCHRG_U_$$GET1^DIQ(389.9,IBDIV_",",.04,"E") ; IB*2.0*720
....S ^TMP($J,"IBOMHC","IDX",IBNM,IBDOS,IBCHTYPE,0)=IBCT,^TMP($J,"IBOMHC","IDX1",DFN,IBDOS)="" ; IB*2.0*720
...I $D(IBCPTARY)>9,I="R45.851" D ;CPT codes extracted and Dx is R45.851 IB*2.0*720
....S IBCPT="" F S IBCPT=$O(IBCPTARY(IBCPT)) Q:IBCPT="" D
.....S IBCT=IBCT+1
.....S ^TMP($J,"IBOMHC",IBCT)=IBNM_U_IBID_U_IBBLNO_U_IBSTABR_U_IBBDSC_U_$$FMTE^XLFDT(IBDOS,9)_U_$S(I="UNK":"",1:I)_U_IBCPT_U_IBCHRG_U_$$GET1^DIQ(389.9,IBDIV_",",.04,"E") ; IB*2.0*720
.....S ^TMP($J,"IBOMHC","IDX",IBNM,IBDOS,IBCHTYPE,IBCPT)=IBCT,^TMP($J,"IBOMHC","IDX1",DFN,IBDOS)="" ; IB*2.0*720
... ;Check to see if the HCPCS code T2034 assigned to the copay.
...I $D(IBCPTARY("T2034")) D
....S IBCPT="" F S IBCPT=$O(IBCPTARY(IBCPT)) Q:IBCPT="" D
.....S IBCT=IBCT+1
.....S ^TMP($J,"IBOMHC",IBCT)=IBNM_U_IBID_U_IBBLNO_U_IBSTABR_U_IBBDSC_U_$$FMTE^XLFDT(IBDOS,9)_U_$S(I="UNK":"",1:I)_U_IBCPT_U_IBCHRG_U_$$GET1^DIQ(389.9,IBDIV_",",.04,"E") ; IB*2.0*720
.....S ^TMP($J,"IBOMHC","IDX",IBNM,IBDOS,IBCHTYPE,IBCPT)=IBCT,^TMP($J,"IBOMHC","IDX1",DFN,IBDOS)="" ; IB*2.0*720
...Q
..Q
.Q
;
Q
;
ISELIG(DFN) ; check if given patient is COMPACT Act eligible
;
; DFN - patient's DFN
;
; returns 1 if patient is COMPACT Act eligible, 0 otherwise
;
N RES,VACOM
S RES=0 I +$G(DFN)>0 D CAI^VADPT S RES=+$G(VACOM("CAI"))
Q RES
;
GETPMDX(IBPM,IBDXARY) ;Retrieve Dx's from the PTF file via the Patient Movement file.
;
N IBADPM,IBPTF
;
S IBADPM=$$GET1^DIQ(405,IBPM_",",.14,"I")
S IBPTF=$$GET1^DIQ(405,$S(IBADPM=IBPM:IBPM,1:IBADPM)_",",.16,"I")
Q:IBPTF=""
D GETPTFDX(IBPTF,.IBDXARY)
Q
;
GETPTFDX(IBPTF,IBDXARY) ; Retrieve all of the DX codes assigned during an outpatient visit
;
;INPUT: IBPTF - IEN of PTF record in File 45
;OUTPUT: IBDXARY - Array of Diagnoses for the PTF record passed in
;
N IBCT,IBLP,IBMVTYP,IBDT,IBDXIEN,IBDX,IBPTFD
;
K ^TMP($J,"IBDX")
;
S IBCT=0
D PTFDX^IBCSC4F(IBPTF)
S IBMVTYP=""
F S IBMVTYP=$O(^TMP($J,"IBDX",IBMVTYP)) Q:IBMVTYP="" D
. S IBDT=0
. F S IBDT=$O(^TMP($J,"IBDX",IBMVTYP,IBDT)) Q:'IBDT D
. . S IBLP=0
. . F S IBLP=$O(^TMP($J,"IBDX",IBMVTYP,IBDT,IBLP)) Q:'IBLP D
. . . S IBPTFD=$G(^TMP($J,"IBDX",IBMVTYP,IBDT,IBLP))
. . . S IBDXIEN=$P(IBPTFD,U),IBDX=$$CODEC^ICDEX(80,IBDXIEN)
. . . I IBDX'="",'$D(IBDXARY(IBDX)) S IBDXARY(IBDX)=""
;
K ^TMP($J,"IBDX")
Q
;
GETPCEDX(IBPCE,IBDXARY) ; Retrieve the list of diagnoses associated with an Outpatient Encounter
;
N IBDX,IBDXB,IBDXC,IBI,IBPCD,K,IBDT,IBID,IBIFN
S (IBDX,IBDXB)=""
;
;Extract the Diagnosis info from the encounter
D OEDX^IBCU81(IBPCE,.IBDX,.IBDXB)
;Loop through the Billable diagnoses and store in IBDXARY for further review
S IBI=0
F S IBI=$O(IBDXB(IBI)) Q:'IBI D
.S IBDXC=$$CODEC^ICDEX(80,IBI)
.I IBDXC'="",'$D(IBDXARY(IBDXC)) S IBDXARY(IBDXC)=""
.Q
;
Q
;
GETPCECP(IBPCE,IBCPTARY) ; Retrieve the list of CPT Codes associated with an Outpatient Encounter
;
N IBCPT,IBCPTRET,IBERR,IBLP
S IBCPT="IBCPTRET"
;
; Call the PCE software to retrieve the CPT code info for the visit in array IBCPTARR via indirection.
D GETCPT^SDOE(IBPCE,.IBCPT,.IBERR)
S IBLP=0 F S IBLP=$O(IBCPTRET(IBLP)) Q:'IBLP S IBCPTARY($$GET1^DIQ(81,$P(IBCPTRET(IBLP),U)_",",.01,"E"))=""
Q
;
PRINT(IBSTRT,IBEND) ; Print the results
N IBI,IBX,IBPAGE,IBLN,QUIT,IBDOS,IBNM,IBDIV,IBDIVIEN,IBCT
I $E(IOST,1,2)["C-",'$D(ZTQUEUED) W @IOF
I IBEXCEL D
.W @IOF
.W !,"COMPACT ACT Copay Review Report from ",$$FMTE^XLFDT(IBSTRT)," to ",$$FMTE^XLFDT($P(IBEND,"."))," Date of Report: ",$$FMTE^XLFDT($$DT^XLFDT())
.W !,"Patient Name",U,"ID",U,"Bill Number",U,"Stat",U,"Descr.",U,"Dt of Serv.",U,"DX",U,"Proc.",U,"Amount ($)",U,"Division"
.Q
I 'IBEXCEL D
.S IBPAGE=0 D HDR(IBSTRT,IBEND)
.I '$D(^TMP($J,"IBOMHC")) W !!!," There were no copayments within the specified date range that were potentially COMPACT ACT eligible",!!!
.Q
S IBNM="" F S IBNM=$O(^TMP($J,"IBOMHC","IDX",IBNM)) Q:IBNM="" D Q:$G(QUIT)
.S IBDOS=0 F S IBDOS=$O(^TMP($J,"IBOMHC","IDX",IBNM,IBDOS)) Q:'IBDOS D Q:$G(QUIT)
..S IBI=0 F S IBI=$O(^TMP($J,"IBOMHC","IDX",IBNM,IBDOS,IBI)) Q:'IBI D Q:$G(QUIT)
...S IBX="" F S IBX=$O(^TMP($J,"IBOMHC","IDX",IBNM,IBDOS,IBI,IBX)) Q:IBX="" D Q:$G(QUIT)
....S IBCT=^TMP($J,"IBOMHC","IDX",IBNM,IBDOS,IBI,IBX),IBDATA=$G(^TMP($J,"IBOMHC",IBCT))
....I IBEXCEL W !,$E(IBNM,1,18),U,$P(IBDATA,U,2,10) Q
....W !,$E(IBNM,1,18),?20,$P(IBDATA,U,2),?26,$P(IBDATA,U,3),?39,$P(IBDATA,U,4),?44,$P(IBDATA,U,5),?58,$P(IBDATA,U,6),?71,$P(IBDATA,U,7)
....W ?80,$P(IBDATA,U,8),?89,$$RJ^XLFSTR($J($P(IBDATA,U,9),10,2),11),?108,$P(IBDATA,U,10)
....S IBLN=IBLN+1
....I IBLN>(IOSL-3) D HDR(IBSTRT,IBEND)
....Q
...Q
..Q
.Q
I 'IBEXCEL Q:$G(QUIT) I IBPAGE>0,'$D(ZTQUEUED) D PAUSE W @IOF
Q
;
HDR(IBSTRT,IBEND) ; print header
;
N IBX,I,IBCT
I IBPAGE>0,'$D(ZTQUEUED) D PAUSE W @IOF I $G(QUIT) Q
S IBPAGE=IBPAGE+1
W !,"COMPACT ACT Copay Review Report from ",$$FMTE^XLFDT(IBSTRT)," to ",$$FMTE^XLFDT($P(IBEND,".")),?80,"Date of Report: ",?96,$$FMTE^XLFDT($$DT^XLFDT()),?120,"Page: ",IBPAGE
I 'IBSD!$G(VAUTD)=1 W !,"For All Divisions"
E W !,"For Division(s) - " S (I,IBCT)=0 F S I=$O(VAUTD(I)) Q:'I W:IBCT>0 "," W $G(VAUTD(I)) S IBCT=IBCT+1
W !!,"Patient Name",?22,"ID",?26,"Bill Number",?39,"Stat",?44,"Descr.",?58,"Dt of Serv.",?71,"DX",?80,"Proc.",?90,"Amount ($)",?105,"Division" ; IB*2.0*720
W ! F IBX=1:1:132 W "-" ; IB*2.0*720
S IBLN=6
Q
;
PAUSE ;Press Return to Continue
N DIR,DUOUT,DTOUT,DIRUT
S DIR(0)="E" D ^DIR
I $D(DIRUT) S QUIT=1
W !
Q
;
GETDX() ; Populate the list of DX codes
;
N IBDXD
;
;Retrieve Specific Diagnosis codes
F I=1:1 S IBDATA=$T(DXSLIST+I) S IBDXD=$P(IBDATA,";",3) Q:IBDXD="EXIT" S ^TMP($J,"IBOMHCDX","IBDXS",IBDXD)=+$P(IBDATA,";",4)
;
Q
;
CMPDX(IBDX,IBCPTARY) ; Check to see if the diagnosis is a Compact Act related Diagnosis.
;
; INPUT: IBDX - ICD-10 DIAGNOSIS CODE
; Returns: 0 - Not related 1 COMPACT Act related diagnosis
;
N IBDXGRP,IBFOUND,IBLP,IBCPTN
;
S IBFOUND=0
;
;If the code matches a specific code related to COMPACT
I $D(^TMP($J,"IBOMHCDX","IBDXS",IBDX)) D Q IBFOUND
.S IBCPTN=+$G(^TMP($J,"IBOMHCDX","IBDXS",IBDX))
.I 'IBCPTN!($D(IBCPTARY)<10) S IBFOUND=1 Q ;No CPT Code needed to confirm COMPACT related Diagnosis
.; Check the CPT temporary array to see if the CPT code associated with the Diagnosis is present in the encounter.
.I $D(IBCPTARY(IBCPTN)) S IBFOUND=1
.Q
;
;Dx code not potentially related to COMPACT Act.
Q IBFOUND
;
DXSLIST ; List of Specific Compact Act Related Diagnosis codes
;;T14.91XA;0
;;T14.91XD;0
;;T14.91XS;0
;;R45.851;0
;;EXIT
Q
;
GETDIV() ; Ask to filter by Division. If so, select the division.
;
N DIROUT,DTOUT,DUOUT,DIRUT,X,Y
; Ask to filter by division.
S DIR(0)="Y",DIR("B")="NO"
S DIR("A")="Do you wish to filter this report by division"
S DIR("?")="^S IBOFF=1 D HELP^IBJDF1H"
D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q -1 ; Escape command given
S IBSD=+Y K DIROUT,DTOUT,DUOUT,DIRUT
;
Q:'IBSD 0
;
;Sort/filter by division selected Ask for division
; - Issue prompt for division.
K X,Y N X,Y ;Clear and reset X and Y for the next prompt
;
;Prompt for Division to filter on.
I IBSD D PSDR^IBODIV I Y<0 Q -1 ;Escape command given
;
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOMHC 13896 printed Sep 23, 2025@20:02:09 Page 2
IBOMHC ;SAB/EDE - COMPACT ACT COPAY Review Report ;JUL 12 2021
+1 ;;2.0;INTEGRATED BILLING;**709,720,736,772**;21-MAR-94;Build 6
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference to $$CODEC^ICDEX in ICR #5747
+5 ; Reference to $$RX^PSO52API in ICR #4820
+6 ; Reference to $$GETCPT^SDOE in ICR #2546
+7 ; Reference to $$RXSITE^PSOBPSUT in ICR #4701
+8 ; Reference to FILE #405 in ICR #419
+9 ; Reference to FILE #40.8 in ICR #417
+10 ;
EN ;
+1 ;
+2 NEW IBSTART,IBEND,IBEXCEL,IBSTOP,IBSD,VAUTD
+3 NEW POP,ZTDESC,ZTRTN,ZTSAVE,ZTSK,%ZIS
+4 ;Initialze Date fields
+5 SET (IBSTART,IBEND)=""
SET IBSTOP=0
+6 ;Get the start and end dates.
+7 DO DATESEL(.IBSTART,.IBEND,"Date Copay Billed")
+8 if IBSTOP
QUIT
+9 ;Ask to sort by Division or not
+10 SET IBSD=$$GETDIV()
+11 ;User requested an exit
if IBSD<0
QUIT
+12 ;
+13 WRITE !!,"** This report can take a while to run and may be queued to run after hours. **",!
+14 WRITE !,"Note: Copay displays only if at least one COMPACT diagnosis is hit.",!
+15 ; export to Excel?
+16 SET IBEXCEL=$$GETEXCEL^IBUCMM()
IF IBEXCEL<0
QUIT
+17 IF IBEXCEL
DO PRTEXCEL^IBUCMM()
+18 ; IB*2.0*720
if 'IBEXCEL
WRITE !!,"Report requires 132 columns.",!
+19 ;
+20 ; ask for device
+21 KILL IOP,IO("Q")
+22 SET %ZIS="MQ"
SET %ZIS("B")=""
SET POP=0
DO ^%ZIS
if POP
QUIT
+23 ; queued report: ask if print queue should be cleared, then queue task
IF $DATA(IO("Q"))
Begin DoDot:1
+24 SET ZTDESC="COMPACT ACT Copay Review Report Report"
+25 SET ZTRTN="MAIN^IBOMHC"
+26 SET ZTSAVE("IBSTART")=IBSTART
SET ZTSAVE("IBEXCEL")=IBEXCEL
SET ZTSAVE("IBEND")=IBEND
SET ZTSAVE("VAUTD")=""
SET ZTSAVE("VAUTD(")=""
SET ZTSAVE("ZTREQ")="@"
+27 SET ZTSAVE("IBSD")=IBSD
+28 DO ^%ZTLOAD
DO HOME^%ZIS
+29 IF $GET(ZTSK)
WRITE !!,"Report compilation has started with task# ",ZTSK,".",!
+30 QUIT
End DoDot:1
QUIT
+31 ;
+32 DO MAIN
+33 QUIT
+34 ;
MAIN ; Main routine to gather and print the report
+1 ;
+2 KILL ^TMP($JOB,"IBOMHC"),^TMP($JOB,"IBOMHCDX")
+3 DO COLLECT
+4 DO PRINT(IBSTART,IBEND)
+5 QUIT
+6 ;
DATESEL(DATESTRT,DATEEND,DESCR) ; prompt for start and end dates
+1 ;
+2 ; sets DATESTRT and DATEEND vars to start date and end date respectively, sets IBSTOP=1 on user exit
+3 ;
+4 NEW DIR,DUOUT,DTOUT,DIRUT,X,Y
+5 NEW CADT,DT7
+6 ; COMPACT ACT Benefit start date from 350.9/71.02
SET CADT=$PIECE($GET(^IBE(350.9,1,71)),U,2)
+7 ; today's date - 7 days
SET DT7=$$FMADD^XLFDT(DT,-7)
+8 SET DIR(0)="DA^"_CADT_":"_DT_":EX"
+9 SET DIR("A")="Start with "_$SELECT($GET(DESCR)'="":DESCR_" ",1:"")_": "
+10 SET DIR("B")=$$FMTE^XLFDT($SELECT(DT7<CADT:CADT,1:DT7),"1D")
+11 SET DIR("?",1)=" Please enter a valid start date."
+12 SET DIR("?",2)=" This date must not be in the future."
+13 SET DIR("?")=" It also may not precede COMPACT ACT Benefit start date ("_$$FMTE^XLFDT(CADT)_")"
+14 DO ^DIR
+15 IF $DATA(DIRUT)
SET IBSTOP=1
GOTO DATESELX
+16 SET DATESTRT=Y
+17 ; End date
DATESEL1 ;
+1 SET DIR("A")=" End with "_$SELECT($GET(DESCR)'="":DESCR_" ",1:"")_": "
+2 SET DIR("B")=$$FMTE^XLFDT($$FMADD^XLFDT(DT),"1D")
+3 SET DIR("?",1)=" Please enter a valid end date."
+4 SET DIR("?")=" This date must not precede the start date entered above."
+5 DO ^DIR
+6 IF $DATA(DIRUT)
SET IBSTOP=1
GOTO DATESELX
+7 IF Y<DATESTRT
WRITE !," End Date must not precede the Start Date."
GOTO DATESEL1
+8 SET DATEEND=Y
+9 WRITE !?5,"*** Selected date range from ",$$FMTE^XLFDT(DATESTRT)," to ",$$FMTE^XLFDT(DATEEND)," ***"
+10 ;
DATESELX ; dates prompt exit point
+1 QUIT
+2 ;
COLLECT ; review the copays in the specified period for possible COMPACT Act related copays to review
+1 ;
+2 ; IB*2.0*720
NEW IBERROR,IBN,IBDXARY,IBPTF,IBDATA,IBLP,IBBLNO,IBCT,VADM,IBPM,IBPCE,IBRX,IBVADM,I,IBCPT,IBDIV,IBADM
+3 NEW DFN,DONE,IBBDSC,IBCHTYPE,IBCHRG,IBDOS,IBNM,IBRF,IBRFFL,IBDATA1,IBLPDT,IBSTATNM,IBSTAT,IBSTABR
+4 SET IBCT=0
+5 SET IBLPDT=IBSTART-.001
SET IBEND=IBEND+.999999
+6 ;Load list of possible DXs into a TMP array
+7 DO GETDX
+8 FOR
SET IBLPDT=$ORDER(^IB("D",IBLPDT))
if 'IBLPDT
QUIT
if IBLPDT>IBEND
QUIT
Begin DoDot:1
+9 SET IBLP=0
+10 ;Loop through file #350 using the Date Billed field within the Start and end Period
+11 FOR
SET IBLP=$ORDER(^IB("D",IBLPDT,IBLP))
if 'IBLP
QUIT
Begin DoDot:2
+12 ;kill and re-init arrays
+13 KILL IBDXARY,IBCPTARY,VADM
+14 SET IBDXARY=""
SET IBCPTARY=""
+15 ; Get Copay Data
+16 SET IBDATA=$GET(^IB(IBLP,0))
SET IBDATA1=$GET(^IB(IBLP,1))
+17 SET IBSTATNM=$$GET1^DIQ(350,IBLP_",",.05,"E")
IF "^BILLED^HOLD - RATE^HOLD - REVIEW^ON HOLD^"'[(U_IBSTATNM_U)
QUIT
+18 SET DFN=$PIECE(IBDATA,U,2)
IF '$$ISELIG(DFN)
QUIT
+19 ;Extract field (.04)[RESULTING FROM]
+20 SET IBRF=$PIECE(IBDATA,U,4)
+21 ;If no file number or ":" in field, skip and go to the next.
+22 if IBRF'["
QUIT
+23 ;Extract the file from the 1st ":" piece
+24 SET IBRFFL=$PIECE(IBRF,":")
+25 ;If the copay is a RX copay, quit.
+26 if $$GET1^DIQ(350.1,$PIECE(IBDATA,U,3)_",",.11,"I")=5
QUIT
+27 ;Extract date of service
+28 ; IB*2.0*772
SET IBDOS=""
if IBRFFL'=52
SET IBDOS=$PIECE(IBDATA,U,14)
+29 if 'IBDOS
QUIT
+30 ; Check division IB*2.0*720
+31 SET IBDIV=""
+32 IF IBRFFL=405
SET IBDIV=$$INP^IBJDF2($PIECE(IBRF,":",2))
+33 IF IBRFFL=45
SET IBADM=$ORDER(^DGPM("APTF",$PIECE(IBRF,":",2),0))
if IBADM
SET IBDIV=$$INP^IBJDF2(IBADM)
+34 IF IBRFFL=409.68
SET IBDIV=$$OPT^IBJDF2(IBDOS,DFN)
+35 if IBDIV=""
SET IBDIV=+$$PRIM^VASITE()
+36 ; quit if not a selected division.
IF IBSD
IF 'VAUTD
if '$DATA(VAUTD(IBDIV))
QUIT
+37 ;
+38 ; IB*2.0*720 moved line from above
DO DEM^VADPT
MERGE IBVADM=VADM
+39 ; IB*2.0*720
SET IBNM=IBVADM(1)
SET IBCHTYPE=$PIECE(IBDATA,U,3)
if IBCHTYPE=""
QUIT
if $DATA(^TMP($JOB,"IBOMHC","IDX",IBNM,IBDOS,IBCHTYPE))
QUIT
+40 if $$GET1^DIQ(350.1,IBCHTYPE,.05,"E")'="NEW"
QUIT
+41 ;If file is 45 (PTF), lookup the primary and Secondary diagnoses
+42 IF IBRFFL=45
SET IBPTF=$PIECE(IBRF,":",2)
DO GETPTFDX(IBPTF,.IBDXARY)
+43 ;If file is 409.68, lookup the diagnoses using OPTDX^IBCSC4D
+44 IF IBRFFL=409.68
SET IBPCE=$PIECE(IBRF,":",2)
DO GETPCEDX(IBPCE,.IBDXARY)
DO GETPCECP(IBPCE,.IBCPTARY)
+45 ;If file is 405, grab the PTF or Diagnoses Text Strings.
+46 IF IBRFFL=405
SET IBPM=$PIECE(IBRF,":",2)
DO GETPMDX(IBPM,.IBDXARY)
+47 ;If file is 52, look the prescription to get the diagnosis associated with it
+48 SET IBID=$EXTRACT(IBVADM(1),1)_$PIECE($PIECE(IBVADM(2),U,2),"-",3)
+49 SET IBSTAT=$PIECE(IBDATA,U,5)
+50 IF IBSTATNM["HOLD"
SET IBSTABR="HOLD"
+51 IF IBSTATNM'["HOLD"
SET IBSTABR=$EXTRACT($$GET1^DIQ(350.21,IBSTAT_",",.03,"E"),1,4)
+52 SET IBBDSC=$EXTRACT($$GET1^DIQ(350.1,IBCHTYPE,.01,"E"),1,12)
+53 SET IBCHRG=$PIECE(IBDATA,U,7)
SET IBBLNO=$PIECE(IBDATA,U,11)
+54 SET DONE=0
SET I=""
FOR
SET I=$ORDER(IBDXARY(I))
if I=""
QUIT
Begin DoDot:3
+55 IF I'="UNK"
IF '$$CMPDX(I,.IBCPTARY)
IF '$DATA(IBCPTARY("T2034"))
QUIT
+56 SET DONE=1
+57 ;No CPT Codes Extracted or Dx is not R45.851 IB*2.0*720
IF $DATA(IBCPTARY)<10!(I'="R45.851")
Begin DoDot:4
+58 ;T2034 visit only, so process this below.
if '$$CMPDX(I,.IBCPTARY)
QUIT
+59 SET IBCT=IBCT+1
+60 ; IB*2.0*720
SET ^TMP($JOB,"IBOMHC",IBCT)=IBNM_U_IBID_U_IBBLNO_U_IBSTABR_U_IBBDSC_U_$$FMTE^XLFDT(IBDOS,9)_U_$SELECT(I="UNK":"",1:I)_U_U_IBCHRG_U_$$GET1^DIQ(389.9,IBDIV_",",.04,"E")
+61 ; IB*2.0*720
SET ^TMP($JOB,"IBOMHC","IDX",IBNM,IBDOS,IBCHTYPE,0)=IBCT
SET ^TMP($JOB,"IBOMHC","IDX1",DFN,IBDOS)=""
End DoDot:4
+62 ;CPT codes extracted and Dx is R45.851 IB*2.0*720
IF $DATA(IBCPTARY)>9
IF I="R45.851"
Begin DoDot:4
+63 SET IBCPT=""
FOR
SET IBCPT=$ORDER(IBCPTARY(IBCPT))
if IBCPT=""
QUIT
Begin DoDot:5
+64 SET IBCT=IBCT+1
+65 ; IB*2.0*720
SET ^TMP($JOB,"IBOMHC",IBCT)=IBNM_U_IBID_U_IBBLNO_U_IBSTABR_U_IBBDSC_U_$$FMTE^XLFDT(IBDOS,9)_U_$SELECT(I="UNK":"",1:I)_U_IBCPT_U_IBCHRG_U_$$GET1^DIQ(389.9,IBDIV_",",.04,"E")
+66 ; IB*2.0*720
SET ^TMP($JOB,"IBOMHC","IDX",IBNM,IBDOS,IBCHTYPE,IBCPT)=IBCT
SET ^TMP($JOB,"IBOMHC","IDX1",DFN,IBDOS)=""
End DoDot:5
End DoDot:4
+67 ;Check to see if the HCPCS code T2034 assigned to the copay.
+68 IF $DATA(IBCPTARY("T2034"))
Begin DoDot:4
+69 SET IBCPT=""
FOR
SET IBCPT=$ORDER(IBCPTARY(IBCPT))
if IBCPT=""
QUIT
Begin DoDot:5
+70 SET IBCT=IBCT+1
+71 ; IB*2.0*720
SET ^TMP($JOB,"IBOMHC",IBCT)=IBNM_U_IBID_U_IBBLNO_U_IBSTABR_U_IBBDSC_U_$$FMTE^XLFDT(IBDOS,9)_U_$SELECT(I="UNK":"",1:I)_U_IBCPT_U_IBCHRG_U_$$GET1^DIQ(389.9,IBDIV_",",.04,"E")
+72 ; IB*2.0*720
SET ^TMP($JOB,"IBOMHC","IDX",IBNM,IBDOS,IBCHTYPE,IBCPT)=IBCT
SET ^TMP($JOB,"IBOMHC","IDX1",DFN,IBDOS)=""
End DoDot:5
End DoDot:4
+73 QUIT
End DoDot:3
if DONE
QUIT
+74 QUIT
End DoDot:2
+75 QUIT
End DoDot:1
+76 ;
+77 QUIT
+78 ;
ISELIG(DFN) ; check if given patient is COMPACT Act eligible
+1 ;
+2 ; DFN - patient's DFN
+3 ;
+4 ; returns 1 if patient is COMPACT Act eligible, 0 otherwise
+5 ;
+6 NEW RES,VACOM
+7 SET RES=0
IF +$GET(DFN)>0
DO CAI^VADPT
SET RES=+$GET(VACOM("CAI"))
+8 QUIT RES
+9 ;
GETPMDX(IBPM,IBDXARY) ;Retrieve Dx's from the PTF file via the Patient Movement file.
+1 ;
+2 NEW IBADPM,IBPTF
+3 ;
+4 SET IBADPM=$$GET1^DIQ(405,IBPM_",",.14,"I")
+5 SET IBPTF=$$GET1^DIQ(405,$SELECT(IBADPM=IBPM:IBPM,1:IBADPM)_",",.16,"I")
+6 if IBPTF=""
QUIT
+7 DO GETPTFDX(IBPTF,.IBDXARY)
+8 QUIT
+9 ;
GETPTFDX(IBPTF,IBDXARY) ; Retrieve all of the DX codes assigned during an outpatient visit
+1 ;
+2 ;INPUT: IBPTF - IEN of PTF record in File 45
+3 ;OUTPUT: IBDXARY - Array of Diagnoses for the PTF record passed in
+4 ;
+5 NEW IBCT,IBLP,IBMVTYP,IBDT,IBDXIEN,IBDX,IBPTFD
+6 ;
+7 KILL ^TMP($JOB,"IBDX")
+8 ;
+9 SET IBCT=0
+10 DO PTFDX^IBCSC4F(IBPTF)
+11 SET IBMVTYP=""
+12 FOR
SET IBMVTYP=$ORDER(^TMP($JOB,"IBDX",IBMVTYP))
if IBMVTYP=""
QUIT
Begin DoDot:1
+13 SET IBDT=0
+14 FOR
SET IBDT=$ORDER(^TMP($JOB,"IBDX",IBMVTYP,IBDT))
if 'IBDT
QUIT
Begin DoDot:2
+15 SET IBLP=0
+16 FOR
SET IBLP=$ORDER(^TMP($JOB,"IBDX",IBMVTYP,IBDT,IBLP))
if 'IBLP
QUIT
Begin DoDot:3
+17 SET IBPTFD=$GET(^TMP($JOB,"IBDX",IBMVTYP,IBDT,IBLP))
+18 SET IBDXIEN=$PIECE(IBPTFD,U)
SET IBDX=$$CODEC^ICDEX(80,IBDXIEN)
+19 IF IBDX'=""
IF '$DATA(IBDXARY(IBDX))
SET IBDXARY(IBDX)=""
End DoDot:3
End DoDot:2
End DoDot:1
+20 ;
+21 KILL ^TMP($JOB,"IBDX")
+22 QUIT
+23 ;
GETPCEDX(IBPCE,IBDXARY) ; Retrieve the list of diagnoses associated with an Outpatient Encounter
+1 ;
+2 NEW IBDX,IBDXB,IBDXC,IBI,IBPCD,K,IBDT,IBID,IBIFN
+3 SET (IBDX,IBDXB)=""
+4 ;
+5 ;Extract the Diagnosis info from the encounter
+6 DO OEDX^IBCU81(IBPCE,.IBDX,.IBDXB)
+7 ;Loop through the Billable diagnoses and store in IBDXARY for further review
+8 SET IBI=0
+9 FOR
SET IBI=$ORDER(IBDXB(IBI))
if 'IBI
QUIT
Begin DoDot:1
+10 SET IBDXC=$$CODEC^ICDEX(80,IBI)
+11 IF IBDXC'=""
IF '$DATA(IBDXARY(IBDXC))
SET IBDXARY(IBDXC)=""
+12 QUIT
End DoDot:1
+13 ;
+14 QUIT
+15 ;
GETPCECP(IBPCE,IBCPTARY) ; Retrieve the list of CPT Codes associated with an Outpatient Encounter
+1 ;
+2 NEW IBCPT,IBCPTRET,IBERR,IBLP
+3 SET IBCPT="IBCPTRET"
+4 ;
+5 ; Call the PCE software to retrieve the CPT code info for the visit in array IBCPTARR via indirection.
+6 DO GETCPT^SDOE(IBPCE,.IBCPT,.IBERR)
+7 SET IBLP=0
FOR
SET IBLP=$ORDER(IBCPTRET(IBLP))
if 'IBLP
QUIT
SET IBCPTARY($$GET1^DIQ(81,$PIECE(IBCPTRET(IBLP),U)_",",.01,"E"))=""
+8 QUIT
+9 ;
PRINT(IBSTRT,IBEND) ; Print the results
+1 NEW IBI,IBX,IBPAGE,IBLN,QUIT,IBDOS,IBNM,IBDIV,IBDIVIEN,IBCT
+2 IF $EXTRACT(IOST,1,2)["C-"
IF '$DATA(ZTQUEUED)
WRITE @IOF
+3 IF IBEXCEL
Begin DoDot:1
+4 WRITE @IOF
+5 WRITE !,"COMPACT ACT Copay Review Report from ",$$FMTE^XLFDT(IBSTRT)," to ",$$FMTE^XLFDT($PIECE(IBEND,"."))," Date of Report: ",$$FMTE^XLFDT($$DT^XLFDT())
+6 WRITE !,"Patient Name",U,"ID",U,"Bill Number",U,"Stat",U,"Descr.",U,"Dt of Serv.",U,"DX",U,"Proc.",U,"Amount ($)",U,"Division"
+7 QUIT
End DoDot:1
+8 IF 'IBEXCEL
Begin DoDot:1
+9 SET IBPAGE=0
DO HDR(IBSTRT,IBEND)
+10 IF '$DATA(^TMP($JOB,"IBOMHC"))
WRITE !!!," There were no copayments within the specified date range that were potentially COMPACT ACT eligible",!!!
+11 QUIT
End DoDot:1
+12 SET IBNM=""
FOR
SET IBNM=$ORDER(^TMP($JOB,"IBOMHC","IDX",IBNM))
if IBNM=""
QUIT
Begin DoDot:1
+13 SET IBDOS=0
FOR
SET IBDOS=$ORDER(^TMP($JOB,"IBOMHC","IDX",IBNM,IBDOS))
if 'IBDOS
QUIT
Begin DoDot:2
+14 SET IBI=0
FOR
SET IBI=$ORDER(^TMP($JOB,"IBOMHC","IDX",IBNM,IBDOS,IBI))
if 'IBI
QUIT
Begin DoDot:3
+15 SET IBX=""
FOR
SET IBX=$ORDER(^TMP($JOB,"IBOMHC","IDX",IBNM,IBDOS,IBI,IBX))
if IBX=""
QUIT
Begin DoDot:4
+16 SET IBCT=^TMP($JOB,"IBOMHC","IDX",IBNM,IBDOS,IBI,IBX)
SET IBDATA=$GET(^TMP($JOB,"IBOMHC",IBCT))
+17 IF IBEXCEL
WRITE !,$EXTRACT(IBNM,1,18),U,$PIECE(IBDATA,U,2,10)
QUIT
+18 WRITE !,$EXTRACT(IBNM,1,18),?20,$PIECE(IBDATA,U,2),?26,$PIECE(IBDATA,U,3),?39,$PIECE(IBDATA,U,4),?44,$PIECE(IBDATA,U,5),?58,$PIECE(IBDATA,U,6),?71,$PIECE(IBDATA,U,7)
+19 WRITE ?80,$PIECE(IBDATA,U,8),?89,$$RJ^XLFSTR($JUSTIFY($PIECE(IBDATA,U,9),10,2),11),?108,$PIECE(IBDATA,U,10)
+20 SET IBLN=IBLN+1
+21 IF IBLN>(IOSL-3)
DO HDR(IBSTRT,IBEND)
+22 QUIT
End DoDot:4
if $GET(QUIT)
QUIT
+23 QUIT
End DoDot:3
if $GET(QUIT)
QUIT
+24 QUIT
End DoDot:2
if $GET(QUIT)
QUIT
+25 QUIT
End DoDot:1
if $GET(QUIT)
QUIT
+26 IF 'IBEXCEL
if $GET(QUIT)
QUIT
IF IBPAGE>0
IF '$DATA(ZTQUEUED)
DO PAUSE
WRITE @IOF
+27 QUIT
+28 ;
HDR(IBSTRT,IBEND) ; print header
+1 ;
+2 NEW IBX,I,IBCT
+3 IF IBPAGE>0
IF '$DATA(ZTQUEUED)
DO PAUSE
WRITE @IOF
IF $GET(QUIT)
QUIT
+4 SET IBPAGE=IBPAGE+1
+5 WRITE !,"COMPACT ACT Copay Review Report from ",$$FMTE^XLFDT(IBSTRT)," to ",$$FMTE^XLFDT($PIECE(IBEND,".")),?80,"Date of Report: ",?96,$$FMTE^XLFDT($$DT^XLFDT()),?120,"Page: ",IBPAGE
+6 IF 'IBSD!$GET(VAUTD)=1
WRITE !,"For All Divisions"
+7 IF '$TEST
WRITE !,"For Division(s) - "
SET (I,IBCT)=0
FOR
SET I=$ORDER(VAUTD(I))
if 'I
QUIT
if IBCT>0
WRITE ","
WRITE $GET(VAUTD(I))
SET IBCT=IBCT+1
+8 ; IB*2.0*720
WRITE !!,"Patient Name",?22,"ID",?26,"Bill Number",?39,"Stat",?44,"Descr.",?58,"Dt of Serv.",?71,"DX",?80,"Proc.",?90,"Amount ($)",?105,"Division"
+9 ; IB*2.0*720
WRITE !
FOR IBX=1:1:132
WRITE "-"
+10 SET IBLN=6
+11 QUIT
+12 ;
PAUSE ;Press Return to Continue
+1 NEW DIR,DUOUT,DTOUT,DIRUT
+2 SET DIR(0)="E"
DO ^DIR
+3 IF $DATA(DIRUT)
SET QUIT=1
+4 WRITE !
+5 QUIT
+6 ;
GETDX() ; Populate the list of DX codes
+1 ;
+2 NEW IBDXD
+3 ;
+4 ;Retrieve Specific Diagnosis codes
+5 FOR I=1:1
SET IBDATA=$TEXT(DXSLIST+I)
SET IBDXD=$PIECE(IBDATA,";",3)
if IBDXD="EXIT"
QUIT
SET ^TMP($JOB,"IBOMHCDX","IBDXS",IBDXD)=+$PIECE(IBDATA,";",4)
+6 ;
+7 QUIT
+8 ;
CMPDX(IBDX,IBCPTARY) ; Check to see if the diagnosis is a Compact Act related Diagnosis.
+1 ;
+2 ; INPUT: IBDX - ICD-10 DIAGNOSIS CODE
+3 ; Returns: 0 - Not related 1 COMPACT Act related diagnosis
+4 ;
+5 NEW IBDXGRP,IBFOUND,IBLP,IBCPTN
+6 ;
+7 SET IBFOUND=0
+8 ;
+9 ;If the code matches a specific code related to COMPACT
+10 IF $DATA(^TMP($JOB,"IBOMHCDX","IBDXS",IBDX))
Begin DoDot:1
+11 SET IBCPTN=+$GET(^TMP($JOB,"IBOMHCDX","IBDXS",IBDX))
+12 ;No CPT Code needed to confirm COMPACT related Diagnosis
IF 'IBCPTN!($DATA(IBCPTARY)<10)
SET IBFOUND=1
QUIT
+13 ; Check the CPT temporary array to see if the CPT code associated with the Diagnosis is present in the encounter.
+14 IF $DATA(IBCPTARY(IBCPTN))
SET IBFOUND=1
+15 QUIT
End DoDot:1
QUIT IBFOUND
+16 ;
+17 ;Dx code not potentially related to COMPACT Act.
+18 QUIT IBFOUND
+19 ;
DXSLIST ; List of Specific Compact Act Related Diagnosis codes
+1 ;;T14.91XA;0
+2 ;;T14.91XD;0
+3 ;;T14.91XS;0
+4 ;;R45.851;0
+5 ;;EXIT
+6 QUIT
+7 ;
GETDIV() ; Ask to filter by Division. If so, select the division.
+1 ;
+2 NEW DIROUT,DTOUT,DUOUT,DIRUT,X,Y
+3 ; Ask to filter by division.
+4 SET DIR(0)="Y"
SET DIR("B")="NO"
+5 SET DIR("A")="Do you wish to filter this report by division"
+6 SET DIR("?")="^S IBOFF=1 D HELP^IBJDF1H"
+7 ; Escape command given
DO ^DIR
KILL DIR
IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT -1
+8 SET IBSD=+Y
KILL DIROUT,DTOUT,DUOUT,DIRUT
+9 ;
+10 if 'IBSD
QUIT 0
+11 ;
+12 ;Sort/filter by division selected Ask for division
+13 ; - Issue prompt for division.
+14 ;Clear and reset X and Y for the next prompt
KILL X,Y
NEW X,Y
+15 ;
+16 ;Prompt for Division to filter on.
+17 ;Escape command given
IF IBSD
DO PSDR^IBODIV
IF Y<0
QUIT -1
+18 ;
+19 QUIT 1
