Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBOMHC

IBOMHC.m

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