- 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 Jan 18, 2025@03:27:01 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