- IBCEMMR ;ALB/ESG - IB MRA Report of Patients w/o Medicare WNR ; 03 Dec 2015 1:57 PM
- ;;2.0;INTEGRATED BILLING;**155,366,528,549**;21-MAR-94;Build 54
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ; Find patients with Medicare supplemental insurance or Medigap
- ; insurance (etc.) but who do not have MEDICARE (WNR) on file as
- ; one of their insurances.
- ;
- Q
- ;
- EN ; Entry Point
- ; ENDDATE - IB*2.0*549 End date for new filtering criteria
- ; STARTDT - IB*2.0*549 Start date for new filtering criteria
- ; IBCEEXCEL - IB*2.0*549 Enabling the capture of output and state report width to be 80 characters to a
- ; spreadsheet
- ;
- ; IB*2.0*549 New variables STARTDT, ENDDATE, IBCEEXCEL, STOP
- ; and STOP2.
- N ENDDATE,IBCEEXCEL,IBMSORT,STARTDT,STOP,STOP2
- ;
- ; IB*2.0*549 Add call to FILTER for new filtering criteria
- F D Q:STOP
- . S STOP=$$FILTER(.STARTDT,.ENDDATE)
- . ; IB*2.0*549 If STOP=1, exit outer loop (ABORTS from FILTER)
- . I 'STOP D
- . . F D Q:STOP!STOP2
- . . . D SORT
- . . . S STOP2='IBMSORT
- . . . ; IB*2.0*549 If no sort parameter, go back to top instead of
- . . . ; jumping to top
- . . . I 'STOP2 D
- . . . . ; IB*2.0*549 Add code to prompt for delimited file output and state report width to be 80 characters
- . . . . ; IB*2.0*549 If true, do SORT again
- . . . . I $$FORMAT(.IBCEEXCEL) D
- . . . . . ; IB*2.0*549 Add STARTDT, ENDDATE and IBCEEXCEL arguments
- . . . . . ; to call to DEVICE tag
- . . . . . D DEVICE(STARTDT,ENDDATE,IBCEEXCEL)
- . . . . . S STOP=2 ; Exit both loops / All input and state report width to be 80 characters good
- . . . . E D
- . . . . . S STOP2=2
- Q
- ;
- FILTER(STARTDT,ENDDATE) ; IB*2.0*549 New tag for getting
- ; start/end dates to filter by Last
- ; Appointment Date
- ; Input and state report width to be 80 characters/Output and state report width to be 80 characters (passed by reference)
- ; STARTDT - Start date for new filtering criteria
- ; ENDDATE - End date for new filtering criteria
- ; Return - 1 for continuing on in EN
- ; 0 for exiting EN
- ;
- N DIR,DIROUT,DIRUT,DTOUT,DUOUT,STOP
- W @IOF,!?20,"Patients Without MEDICARE (WNR) Insurance"
- W !
- W !?2,"This option finds patients who do not have active MEDICARE (WNR) insurance,"
- W !?2,"but who do have active insurance with a Plan Type of Medigap, Carve-Out, or"
- W !?2,"Medicare Secondary. In these cases, MEDICARE (WNR) should be primary."
- W !
- W !?2,"The insurances for all living patients will be analyzed, but"
- W !?2,"you can determine how this information will be sorted."
- W !!
- W !," Please enter Last Appointment Dates:"
- F D Q:STOP
- . D GETSTDT(.STARTDT)
- . I STARTDT?1.N D
- . . D GETENDDT(STARTDT,.ENDDATE)
- . . ; Exit loop (STOP=1) or redo START DATE
- . . S STOP=$S(ENDDATE?1.N:1,1:0)
- . E S STOP=2 ; Exit loop / EN needs to abort
- Q (STOP=2)
- ;
- GETSTDT(STARTDT) ; IB*2.0*549 Get start date for date filter
- ; Input and state report width to be 80 characters/Output and state report width to be 80 characters (Passed by reference)
- ; STARTDT - Start date for new filtering criteria
- ;
- N DIR,DIROUT,DIRUT,DTOUT,DUOUT
- S DIR(0)="D^:-NOW:EX"
- S DIR("A")=" Start DATE"
- S DIR("?",1)=" Please enter a valid date for filtering"
- S DIR("?",2)=" the Last Appointment Date. Future dates"
- S DIR("?")=" are not allowed."
- D ^DIR K DIR
- S STARTDT=Y
- Q
- ;
- GETENDDT(STARTDT,ENDDATE) ; IB*2.0*549 Get end date for date filter
- ; Input and state report width to be 80 characters
- ; STARTDT - Start date for new filtering criteria
- ; ENDDT - End date for new filtering criteria
- ;
- ; Output and state report width to be 80 characters (Passed by reference)
- ; ENDDT - End date for new filtering criteria
- ;
- N DIR,DIROUT,DIRUT,DTOUT,DUOUT
- S DIR(0)="DA^"_STARTDT_":-NOW:EX"
- S DIR("A")=" End DATE: "
- S DIR("B")=$$FMTE^XLFDT($$DT^XLFDT,"2DZ")
- S DIR("?",1)=" Please enter a valid date filtering the"
- S DIR("?",2)=" Last Appointment Date. This date must"
- S DIR("?",3)=" not precede the Start Date. Future"
- S DIR("?")=" dates are not allowed."
- D ^DIR K DIR
- S ENDDATE=Y
- Q
- ;
- FORMAT(IBCEEXCEL) ; IB*2.0*549 - capture the report format from
- ; the user (normal or CSV output and state report width to be 80 characters)
- ; Input and state report width to be 80 characters (passed by reference)
- ; IBCEEXCEL
- ; Output and state report width to be 80 characters
- ; IBCEEXCEL=0 for normal output and state report width to be 80 characters
- ; IBCEEXCEL=1 for CSV (comma separated values) for Excel
- ; Return
- ; 1 for good input and state report width to be 80 characters; or
- ; 0 for going back
- ;
- N DIR,DIROUT,DIRUT,DTOUT,DUOUT,STOP
- S IBCEEXCEL=""
- K DIR S DIR(0)="SA^E:Excel;R:Report"
- S DIR("A")=" (E)xcel Format or (R)eport Format: "
- S DIR("B")="Report"
- W ! D ^DIR
- S IBCEEXCEL=$S(Y="R":0,Y="E":1,1:Y)
- Q $S(IBCEEXCEL?1N:1,1:0)
- ;
- ; IB*2.0*549 Change sort to secondary sort and add documentation
- SORT ; Ask user how to sort the report
- ; (Secondary sort)
- ;
- N CH,DIR,DIROUT,DIRUT,DTOUT,DUOUT
- ; IB*2.0*549 Move IOF, title and description to FILTER tag
- S IBMSORT=""
- ; IB*2.0*549 Primary sort will be by Appointment Date and
- ; Secondary sort will not be by Appointment Date
- S CH="1:Patient Name;2:SSN - Last 4 Digits;3:Insurance Company;"
- S CH=CH_"4:Type of Plan"
- ;
- S DIR(0)="SO^"_CH
- S DIR("A")=" Please enter the secondary Sort Criteria"
- S DIR("B")="Patient Name"
- S DIR("?",1)="The primary sort for this report is the last appointment date. Please enter"
- S DIR("?")="a code from the list to identify the secondary sort."
- D ^DIR
- S:Y IBMSORT=Y
- SORTX ;
- Q
- ;
- COMPILE ; Entry point for both background and foreground task execution
- ;
- ; IB*2.0*549 - Document input and state report width to be 80 characters and output and state report width to be 80 characters
- ; Input and state report width to be 80 characters
- ; ZTQUEUED - Queued flag
- ; STARTDT - Start date for new filtering criteria
- ; ENDDT - End date for new filtering criteria
- ;
- ; Output and state report width to be 80 characters
- ; ZTSTOP - Flag for stopping routine
- ;
- ; IB*2.0*549 - Add DATA and SUBSCRIPT variables and alphabetize variables
- ; IB*2.0*549 - Enables filtering of dates, includes last verified date
- ; LSTVERDT - Last verified date
- ;
- N A,APPT,APTDTE,CNT,DATA,DFN,DPT,GRP,IBNEXT,INS,INSNM,LSTVERDT,MS,PLN
- N PLNTYP,PTNM,RTN,SORT,SSN,SUBSCRIPT,X
- S RTN="IBCEMMR"
- ; IB*2.0*528 - Add IBNEXT subscript to be initialized
- F X=RTN,"IBCEPT","IBSDNEXT","IBDPT","IBNEXT","IBLAST" K ^TMP($J,X)
- S DFN=" ",CNT=0
- F S DFN=$O(^DPT(DFN),-1) Q:'DFN!($G(ZTSTOP)) D
- . S CNT=CNT+1
- . I '$D(ZTQUEUED),CNT#500=0 U IO(0) W "." U IO
- . I $D(ZTQUEUED),CNT#500=0,$$S^%ZTLOAD() S ZTSTOP=1 Q
- . I $P($G(^DPT(DFN,.35)),U,1) Q ; date of death
- . I '$$PTINS(DFN,.MS) Q ; eligible for report
- . S ^TMP($J,"IBNEXT",DFN)=""
- . S ^TMP($J,"IBLAST",DFN)=""
- . S ^TMP($J,"IBDPT",DFN)=""
- ;
- S X=$$NEXT^IBSDU("^TMP($J,""IBNEXT"",")
- S X=$$LAST^IBSDU("^TMP($J,""IBLAST"",")
- ;
- S DFN=0
- F S DFN=$O(^TMP($J,"IBDPT",DFN)) Q:'DFN!($G(ZTSTOP)) D
- . I '$D(ZTQUEUED),CNT#500=0 U IO(0) W "." U IO
- . I $D(ZTQUEUED),CNT#500=0,$$S^%ZTLOAD() S ZTSTOP=1 Q
- . I '$$PTINS(DFN,.MS) ; get MS data
- . S DPT=$G(^DPT(DFN,0))
- . S PTNM=$P(DPT,U,1)
- . I PTNM="" S PTNM="~UNKNOWN"
- . S SSN=$E($P(DPT,U,9),6,99)_" "
- . S:SSN=" " SSN="~UNK"
- . ; IB*2.0*549 - Change default value to empty string
- . S (APPT,IBNEXT)=$G(^TMP($J,"IBNEXT",DFN))
- . I 'APPT S APPT=$G(^TMP($J,"IBLAST",DFN))
- . ;
- . ; IB*2.0*549 - Simplify $S assignment with $$GETAPDT
- . S APTDTE=$$GETAPDT(APPT,IBNEXT)
- . ; IB*2.0*549 - Delete non-day portion of APPT
- . S APPT=APPT\1
- . ; IB*2.0*549 FILTER BASED ON START DATE AND END DATE
- . Q:APTDTE="N/A"!(APPT<STARTDT)!(APPT>ENDDATE)
- . S A=0
- . F S A=$O(MS(A)) Q:'A D
- . . S INS=+$P(MS(A),U,1),GRP=+$P(MS(A),U,2)
- . . S PLN=+$P(MS(A),U,3)
- . . S INSNM=$P($G(^DIC(36,INS,0)),U,1)
- . . I INSNM="" S INSNM="~UNKNOWN"
- . . S PLNTYP=$P($G(^IBE(355.1,PLN,0)),U,1)
- . . I PLNTYP="" S PLNTYP="~UNKNOWN"
- . . ; IB*2.0*549 - Simplify $S assignment
- . . S SORT=$$GETIBMST(IBMSORT,PTNM,SSN,INSNM,PLNTYP)
- . . ; IB*2.0*549 Primary sort order by Last Appointment Date with
- . . ; most recent date at top. Data includes Last
- . . ; Verified Date.
- . . S LSTVERDT=$$GET1^DIQ(2.312,A_","_DFN_",",1.03,"I")
- . . S LSTVERDT=$$FMTE^XLFDT(LSTVERDT,"2DZ")
- . . S DATA=SSN_U_INSNM_U_PLNTYP_U_APTDTE_U_LSTVERDT
- . . S ^TMP($J,RTN,-APPT,SORT,PTNM,DFN,A)=DATA
- . . ; IB*2.0*549 Delete trailing quits
- ;
- I '$G(ZTSTOP) D PRINT ; print the report
- D ^%ZISC ; close the device
- ; IB*2.0*528 Add IBNEXT subscript to be cleaned up
- F SUBSCRIPT=RTN,"IBCEPT","IBSDNEXT","IBDPT","IBNEXT","IBLAST" K ^TMP($J,SUBSCRIPT)
- I $D(ZTQUEUED) S ZTREQ="@" ; purge the task record
- COMPX ;
- Q
- ;
- ; IB*2.0*549 Simplify setting of APTDTE from $S
- GETAPDT(APPT,IBNEXT) ; Get APTDTE from APPT/IBNEXT
- ; Input and state report width to be 80 characters
- ; APPT - Appointment date (external format)
- ; IBNEXT - Next appointment date
- ; Output and state report width to be 80 characters
- ; APTDTE - Appointment date (external format)
- ;
- N APTDTE
- D ; Simplification of $S
- . I APPT S APTDTE=$$FMTE^XLFDT($P(APPT,"."),"2Z") Q
- . I $L(IBNEXT) S APTDTE=IBNEXT Q
- . I $L(APPT) S APTDTE=APPT Q
- . S APTDTE="N/A"
- Q APTDTE
- ;
- ; IB*2.0*549 Simplify setting of SORT from $S
- GETIBMST(IBMSORT,PTNM,SSN,INSNM,PLNTYP) ; Get SORT from PTNM/SSN/INSNM/PLNTYP
- ; Input and state report width to be 80 characters
- ; IBMSORT - Sort choice index
- ; PTNM - Patient name
- ; SSN - SSN
- ; INSNM - Insurance name
- ; PLNTYP - Plan type
- ; Output and state report width to be 80 characters
- ; SORT - Secondary sort for report
- ;
- N SORT
- ; IB*2.0*549 Secondary sort does not include Last Appointment
- ; Date
- D ; Simplification of $S
- . I IBMSORT=1 S SORT=PTNM Q
- . I IBMSORT=2 S SORT=SSN Q
- . I IBMSORT=3 S SORT=INSNM Q
- . I IBMSORT=4 S SORT=PLNTYP Q
- . S SORT=PTNM
- Q SORT
- ;
- PRINT ; print the report to the device specified
- ; IB*2.0*549 APTDTE - Last appointment date (Primary sort criteria)
- ; Add APTDTE/DTOUT/DUOUT and alphabetize variables
- ; Add DF for data found
- N A,APTDTE,CRT,DATA,DF,DFN,DIR,DIROUT,DIRUT,DTOUT,DUOUT,IBX,MAXCNT,PAGECNT,PTNM
- N SORT,STOP,X,Y
- ; IB*2.0*549 APTDTE - Last appointment date (Primary sort criteria)
- S APTDTE=""
- ;
- I IOST["C-" S MAXCNT=IOSL-3,CRT=1
- E S MAXCNT=IOSL-6,CRT=0
- I IBCEEXCEL S IOSL=999999 ; IB*2.0*549 Long screen length for Excel
- ; output and state report width to be 80 characters
- S PAGECNT=0,STOP=0
- ;
- ; IB*2.0*549 Handle no data found in better fashion
- I '$D(^TMP($J,RTN)) D
- . S DF=0
- . D HEADER
- . W !!?5,"No Data Found"
- ;
- ; IB*2.0*549 for Excel CSV, display the header line first before looping
- ; Handle for instances where there is data found
- E D
- . S DF=1
- . I IBCEEXCEL W ! D HEADER Q:STOP
- . ;
- . D PRINT2(.STOP)
- Q:STOP
- W !!?30,"*** End of Report ***"
- ; IB*2.0*549 Where data is found
- I DF,CRT,'$D(ZTQUEUED) S DIR(0)="E" D ^DIR K DIR
- PRINTX ;
- Q
- ;
- PRINT2(STOP) ; Rest of Print tag
- ; IB*2.0*549 Put loops in new tag
- ; IB*2.0*549 Incorporate new primary sort criteria
- S APTDTE=""
- F S APTDTE=$O(^TMP($J,RTN,APTDTE)) Q:APTDTE="" D Q:STOP
- . S SORT=""
- . F S SORT=$O(^TMP($J,RTN,APTDTE,SORT)) Q:SORT="" D Q:STOP
- . . S PTNM=""
- . . F S PTNM=$O(^TMP($J,RTN,APTDTE,SORT,PTNM)) Q:PTNM="" D Q:STOP
- . . . S DFN=0
- . . . F S DFN=$O(^TMP($J,RTN,APTDTE,SORT,PTNM,DFN)) Q:'DFN D Q:STOP
- . . . . S A=0
- . . . . F S A=$O(^TMP($J,RTN,APTDTE,SORT,PTNM,DFN,A)) Q:'A D Q:STOP
- . . . . . S DATA=$G(^TMP($J,RTN,APTDTE,SORT,PTNM,DFN,A))
- . . . . . ; IB*2.0*549 for Excel output and state report width to be 80 characters, print a CSV format record
- . . . . . I IBCEEXCEL D EXCELN(PTNM,DATA) Q
- . . . . . ;
- . . . . . I $Y+1>MAXCNT!'PAGECNT D HEADER Q:STOP
- . . . . . ; IB*2.0*549 Add new field (Last Verified Date)
- . . . . . W !,$E(PTNM,1,16),?19,$P(DATA,U,1),?26,$E($P(DATA,U,2),1,17)
- . . . . . W ?45,$E($P(DATA,U,3),1,12),?59,$P(DATA,U,4),?69,$P(DATA,U,5)
- Q
- ;
- EXCELN(PTNM,DATA) ; IB*2.0*549 output and state report width to be 80 characters one Excel line
- ; Input and state report width to be 80 characters
- ; PTNM - Patient name
- ; DATA - Report data
- ;
- N IBZ
- S IBZ=$$CSV("",PTNM) ; patient name
- S IBZ=$$CSV(IBZ,$P(DATA,U,1)) ; SSN (Keeps leading zeroes)
- S IBZ=$$CSV(IBZ,$P(DATA,U,2)) ; insurance company
- S IBZ=$$CSV(IBZ,$P(DATA,U,3)) ; type of plan
- S IBZ=$$CSV(IBZ,$P(DATA,U,4)) ; appointment date
- S IBZ=$$CSV(IBZ,$P(DATA,U,5)) ; last verified date
- W !,IBZ
- Q
- ;
- ; IB*2.0*549 Add DIR/DIROUT/DIRUT/DTOUT/DUOUT
- ;
- N DIR,DIROUT,DIRUT,DTOUT,DUOUT,HDR,LIN,TAB
- S STOP=0
- ; ask screen user if they want to continue
- I CRT,PAGECNT>0,'$D(ZTQUEUED) D Q:STOP
- . I MAXCNT<51 F LIN=1:1:(MAXCNT-$Y) W !
- . S DIR(0)="E" D ^DIR K DIR
- . I 'Y S STOP=1 Q
- . ; IB*2.0*549 Delete trailing quits
- ;
- S PAGECNT=PAGECNT+1
- ; IB*2.0*549 *** Enable printing to delimited file ***
- I IBCEEXCEL D EXCELHD(ENDDATE,IBMSORT,STARTDT) Q ; IB*2.0*549 For Excel CSV format, display all headers
- ;
- W @IOF,!,"Patients Without MEDICARE (WNR) Insurance"
- S HDR="Page: "_PAGECNT
- S TAB=80-$L(HDR)-1
- W ?TAB,HDR
- ; IB*2.0*549 Appointment Date no longer Secondary Sort option
- W !,"Sorted by Appt, ",$S(IBMSORT=1:"Patient Name",IBMSORT=2:"SSN - Last 4 Digits",IBMSORT=3:"Insurance Company",IBMSORT=4:"Type of Plan",1:"Patient Name")
- S HDR=$$FMTE^XLFDT($$NOW^XLFDT,"1Z")
- S TAB=80-$L(HDR)-1
- W ?TAB,HDR
- W !,"Appointment Dates: ",$$CNVTDT(STARTDT)," - ",$$CNVTDT(ENDDATE)
- ; IB*2.0*549 Added blank line before column headers
- W !!,"Patient Name",?20,"SSN",?26,"Insurance Company"
- ; IB*2.0*549 Add new field (Last Verified Date)
- W ?45,"Type of Plan",?59,"ApptDate",?69,"LstVerDt"
- W !,$$RJ^XLFSTR("",80,"=")
- ;
- ; check for stop request
- I $D(ZTQUEUED),$$S^%ZTLOAD() D Q
- . S (ZTSTOP,STOP)=1
- . W !!!?5,"*** Report Halted by TaskManager Request ***"
- . ; IB*2.0*549 Delete trailing quits
- ;
- Q
- ;
- CNVTDT(DATE) ; IB*2.0*549 Convert from VA internal date to MM/DD/YY
- N DAY,MON,YR
- S YR=(17+$E(DATE))_$E(DATE,2,3),MON=$E(DATE,4,5),DAY=$E(DATE,6,7)
- Q MON_"/"_DAY_"/"_YR
- ;
- EXCELHD(ENDDATE,IBMSORT,STARTDT) ; IB*2.0*549 print an Excel CSV header record (only 1 Excel CSV header
- ; should print for the whole report)
- ; IB*2.0*549 - Added code to enhance report header and simplify setting of IBMSORT
- N IBH,IBHDT,STR
- D NOW^%DTC
- S IBHDT=$$DAT2^IBOUTL($E(%,1,12))
- W !,"Patients Without MEDICARE (WNR) Insurance",?53,"Run On: ",IBHDT
- W !,"Sorted by Appt, "
- D
- . I IBMSORT=1 W "Patient Name" Q
- . I IBMSORT=2 W "SSN - Last 4 Digits" Q
- . I IBMSORT=3 W "Insurance Company" Q
- . I IBMSORT=4 W "Type of Plan" Q
- . W "Patient Name"
- W !,"Appointment Dates: ",$$CNVTDT(STARTDT)," - ",$$CNVTDT(ENDDATE)
- S IBH="Patient Name"
- F STR="SSN","Insurance Company","Type of Plan","ApptDate","LstVerDt" S IBH=IBH_U_STR
- W !!,IBH
- Q
- ;
- CSV(STRING,DATA) ; IB*2.0*549 build the Excel data string for CSV format
- ; Input and state report width to be 80 characters
- ; STRING - Excel data string being added on to
- ; DATA - Data to be added to string
- ; Output and state report width to be 80 characters
- ; STRING - Data string which was added to
- ;
- S DATA=$TR(DATA,U,"?")
- S STRING=$S(STRING="":DATA,1:STRING_U_DATA)
- Q STRING
- ;
- PTINS(DFN,MCRSUP) ; Function to determine if a patient should be
- ; included in this report or not.
- ; Input and state report width to be 80 characters: DFN - patient ien
- ; Output and state report width to be 80 characters: Function value is either 0 (don't include) or 1 (include)
- ; MCRSUP array pass by reference
- ; MCRSUP(seq) = [1] insurance co ien pointer to file 36
- ; [2] group pointer to file 355.3
- ; [3] type of plan pointer to file 355.1
- ;
- ;IB*2.0*549 Abbreviate NEW to N and alphabetize variables
- N A,GP,IBGRP,IBINS,INCLUDE,INS,MCRWNR,MCRZ,PLABBR,TP
- S INCLUDE=0 KILL MCRSUP
- I '$G(DFN) G PTINSX
- I '$D(^DPT(DFN)) G PTINSX
- D ALLWNR^IBCNS1(DFN,"INS",DT)
- S A=0,(MCRWNR,MCRZ)=0
- F S A=$O(INS(A)) Q:'A D Q:MCRWNR
- . S IBINS=$P($G(INS(A,0)),U,1)
- . S IBGRP=$P($G(INS(A,0)),U,18)
- . I $$MCRWNR^IBEFUNC(IBINS) S MCRWNR=1 Q ; Medicare WNR on file
- . S GP=$G(INS(A,355.3)) ; group/plan info
- . S TP=$P(GP,U,9),PLABBR="" ; type of plan pointer
- . I TP S PLABBR=$P($G(^IBE(355.1,TP,0)),U,2) ; plan abbreviation
- . I '$F(".MG.MS.COUT.","."_PLABBR_".") Q ; check plan
- . S MCRZ=1 ; Medicare other on file
- . S MCRSUP(A)=IBINS_U_IBGRP_U_TP
- . ; IB*2.0*549 Delete trailing quits
- ;
- ; If Medicare Other was found, but no Medicare WNR, then include it
- I MCRZ,'MCRWNR S INCLUDE=1
- ;
- PTINSX ;
- I 'INCLUDE K MCRSUP
- Q INCLUDE
- ;
- ; IB*2.0*549 Add STARTDT, ENDDATE and IBCEEXCEL arguments to pass to
- ; DEVICE tag
- DEVICE(STARTDT,ENDDATE,IBCEEXCEL) ; This procedure displays a warning message
- ; AND prompts for the device on which to
- ; print the report.
- ;
- ;IB*2.0*549 Add DIR/DIROUT/DIRUT/DTOUT/DUOUT
- N DIR,DIROUT,DIRUT,DTOUT,DUOUT,POP,ZTDESC,ZTRTN,ZTSAVE
- ; IB*2.0*549 Allow for CSV output and state report width to be 80 characters
- I 'IBCEEXCEL D
- . W !!,"This report is 80 characters wide. "
- . W "Please choose an appropriate device.",!
- E D
- . W !!,"For CSV output and state report width to be 80 characters, turn logging or capture on now."
- . W !,"To avoid undesired wrapping of the data saved to the file,"
- . W !,"please enter ""0;256;99999"" at the ""DEVICE:"" prompt.",!
- ;
- W *7,!!!?14,"*** WARNING ***"
- W !?2,"This report takes a long time to compile!"
- W !!?2,"The active insurance coverage for all living patients is analyzed."
- W !!?2,"It is recommended that you queue this report to the background and"
- W !?2,"run it after hours or on the weekend."
- W !!?2,"This report is 80 characters wide."
- W !
- ;
- S ZTRTN="COMPILE^IBCEMMR"
- S ZTDESC="Patients without MEDICARE (WNR) Insurance"
- S ZTSAVE("IBMSORT")=""
- ; IB*2.0*549 Add code to save STARTDT, ENDDATE and IBCEEXCEL
- S ZTSAVE("STARTDT")=""
- S ZTSAVE("ENDDATE")=""
- S ZTSAVE("IBCEEXCEL")=""
- ; IB*2.0*549 Enable report to choose a file in delimited format
- D EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE,"QM",1)
- I $G(ZTSK) D
- . W !!,"Report compilation has started with task# ",ZTSK,".",!
- . S DIR(0)="E" D ^DIR
- DEVICEX ;
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEMMR 18972 printed Jan 18, 2025@03:12:06 Page 2
- IBCEMMR ;ALB/ESG - IB MRA Report of Patients w/o Medicare WNR ; 03 Dec 2015 1:57 PM
- +1 ;;2.0;INTEGRATED BILLING;**155,366,528,549**;21-MAR-94;Build 54
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ; Find patients with Medicare supplemental insurance or Medigap
- +5 ; insurance (etc.) but who do not have MEDICARE (WNR) on file as
- +6 ; one of their insurances.
- +7 ;
- +8 QUIT
- +9 ;
- EN ; Entry Point
- +1 ; ENDDATE - IB*2.0*549 End date for new filtering criteria
- +2 ; STARTDT - IB*2.0*549 Start date for new filtering criteria
- +3 ; IBCEEXCEL - IB*2.0*549 Enabling the capture of output and state report width to be 80 characters to a
- +4 ; spreadsheet
- +5 ;
- +6 ; IB*2.0*549 New variables STARTDT, ENDDATE, IBCEEXCEL, STOP
- +7 ; and STOP2.
- +8 NEW ENDDATE,IBCEEXCEL,IBMSORT,STARTDT,STOP,STOP2
- +9 ;
- +10 ; IB*2.0*549 Add call to FILTER for new filtering criteria
- +11 FOR
- Begin DoDot:1
- +12 SET STOP=$$FILTER(.STARTDT,.ENDDATE)
- +13 ; IB*2.0*549 If STOP=1, exit outer loop (ABORTS from FILTER)
- +14 IF 'STOP
- Begin DoDot:2
- +15 FOR
- Begin DoDot:3
- +16 DO SORT
- +17 SET STOP2='IBMSORT
- +18 ; IB*2.0*549 If no sort parameter, go back to top instead of
- +19 ; jumping to top
- +20 IF 'STOP2
- Begin DoDot:4
- +21 ; IB*2.0*549 Add code to prompt for delimited file output and state report width to be 80 characters
- +22 ; IB*2.0*549 If true, do SORT again
- +23 IF $$FORMAT(.IBCEEXCEL)
- Begin DoDot:5
- +24 ; IB*2.0*549 Add STARTDT, ENDDATE and IBCEEXCEL arguments
- +25 ; to call to DEVICE tag
- +26 DO DEVICE(STARTDT,ENDDATE,IBCEEXCEL)
- +27 ; Exit both loops / All input and state report width to be 80 characters good
- SET STOP=2
- End DoDot:5
- +28 IF '$TEST
- Begin DoDot:5
- +29 SET STOP2=2
- End DoDot:5
- End DoDot:4
- End DoDot:3
- if STOP!STOP2
- QUIT
- End DoDot:2
- End DoDot:1
- if STOP
- QUIT
- +30 QUIT
- +31 ;
- FILTER(STARTDT,ENDDATE) ; IB*2.0*549 New tag for getting
- +1 ; start/end dates to filter by Last
- +2 ; Appointment Date
- +3 ; Input and state report width to be 80 characters/Output and state report width to be 80 characters (passed by reference)
- +4 ; STARTDT - Start date for new filtering criteria
- +5 ; ENDDATE - End date for new filtering criteria
- +6 ; Return - 1 for continuing on in EN
- +7 ; 0 for exiting EN
- +8 ;
- +9 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,STOP
- +10 WRITE @IOF,!?20,"Patients Without MEDICARE (WNR) Insurance"
- +11 WRITE !
- +12 WRITE !?2,"This option finds patients who do not have active MEDICARE (WNR) insurance,"
- +13 WRITE !?2,"but who do have active insurance with a Plan Type of Medigap, Carve-Out, or"
- +14 WRITE !?2,"Medicare Secondary. In these cases, MEDICARE (WNR) should be primary."
- +15 WRITE !
- +16 WRITE !?2,"The insurances for all living patients will be analyzed, but"
- +17 WRITE !?2,"you can determine how this information will be sorted."
- +18 WRITE !!
- +19 WRITE !," Please enter Last Appointment Dates:"
- +20 FOR
- Begin DoDot:1
- +21 DO GETSTDT(.STARTDT)
- +22 IF STARTDT?1.N
- Begin DoDot:2
- +23 DO GETENDDT(STARTDT,.ENDDATE)
- +24 ; Exit loop (STOP=1) or redo START DATE
- +25 SET STOP=$SELECT(ENDDATE?1.N:1,1:0)
- End DoDot:2
- +26 ; Exit loop / EN needs to abort
- IF '$TEST
- SET STOP=2
- End DoDot:1
- if STOP
- QUIT
- +27 QUIT (STOP=2)
- +28 ;
- GETSTDT(STARTDT) ; IB*2.0*549 Get start date for date filter
- +1 ; Input and state report width to be 80 characters/Output and state report width to be 80 characters (Passed by reference)
- +2 ; STARTDT - Start date for new filtering criteria
- +3 ;
- +4 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT
- +5 SET DIR(0)="D^:-NOW:EX"
- +6 SET DIR("A")=" Start DATE"
- +7 SET DIR("?",1)=" Please enter a valid date for filtering"
- +8 SET DIR("?",2)=" the Last Appointment Date. Future dates"
- +9 SET DIR("?")=" are not allowed."
- +10 DO ^DIR
- KILL DIR
- +11 SET STARTDT=Y
- +12 QUIT
- +13 ;
- GETENDDT(STARTDT,ENDDATE) ; IB*2.0*549 Get end date for date filter
- +1 ; Input and state report width to be 80 characters
- +2 ; STARTDT - Start date for new filtering criteria
- +3 ; ENDDT - End date for new filtering criteria
- +4 ;
- +5 ; Output and state report width to be 80 characters (Passed by reference)
- +6 ; ENDDT - End date for new filtering criteria
- +7 ;
- +8 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT
- +9 SET DIR(0)="DA^"_STARTDT_":-NOW:EX"
- +10 SET DIR("A")=" End DATE: "
- +11 SET DIR("B")=$$FMTE^XLFDT($$DT^XLFDT,"2DZ")
- +12 SET DIR("?",1)=" Please enter a valid date filtering the"
- +13 SET DIR("?",2)=" Last Appointment Date. This date must"
- +14 SET DIR("?",3)=" not precede the Start Date. Future"
- +15 SET DIR("?")=" dates are not allowed."
- +16 DO ^DIR
- KILL DIR
- +17 SET ENDDATE=Y
- +18 QUIT
- +19 ;
- FORMAT(IBCEEXCEL) ; IB*2.0*549 - capture the report format from
- +1 ; the user (normal or CSV output and state report width to be 80 characters)
- +2 ; Input and state report width to be 80 characters (passed by reference)
- +3 ; IBCEEXCEL
- +4 ; Output and state report width to be 80 characters
- +5 ; IBCEEXCEL=0 for normal output and state report width to be 80 characters
- +6 ; IBCEEXCEL=1 for CSV (comma separated values) for Excel
- +7 ; Return
- +8 ; 1 for good input and state report width to be 80 characters; or
- +9 ; 0 for going back
- +10 ;
- +11 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,STOP
- +12 SET IBCEEXCEL=""
- +13 KILL DIR
- SET DIR(0)="SA^E:Excel;R:Report"
- +14 SET DIR("A")=" (E)xcel Format or (R)eport Format: "
- +15 SET DIR("B")="Report"
- +16 WRITE !
- DO ^DIR
- +17 SET IBCEEXCEL=$SELECT(Y="R":0,Y="E":1,1:Y)
- +18 QUIT $SELECT(IBCEEXCEL?1N:1,1:0)
- +19 ;
- +20 ; IB*2.0*549 Change sort to secondary sort and add documentation
- SORT ; Ask user how to sort the report
- +1 ; (Secondary sort)
- +2 ;
- +3 NEW CH,DIR,DIROUT,DIRUT,DTOUT,DUOUT
- +4 ; IB*2.0*549 Move IOF, title and description to FILTER tag
- +5 SET IBMSORT=""
- +6 ; IB*2.0*549 Primary sort will be by Appointment Date and
- +7 ; Secondary sort will not be by Appointment Date
- +8 SET CH="1:Patient Name;2:SSN - Last 4 Digits;3:Insurance Company;"
- +9 SET CH=CH_"4:Type of Plan"
- +10 ;
- +11 SET DIR(0)="SO^"_CH
- +12 SET DIR("A")=" Please enter the secondary Sort Criteria"
- +13 SET DIR("B")="Patient Name"
- +14 SET DIR("?",1)="The primary sort for this report is the last appointment date. Please enter"
- +15 SET DIR("?")="a code from the list to identify the secondary sort."
- +16 DO ^DIR
- +17 if Y
- SET IBMSORT=Y
- SORTX ;
- +1 QUIT
- +2 ;
- COMPILE ; Entry point for both background and foreground task execution
- +1 ;
- +2 ; IB*2.0*549 - Document input and state report width to be 80 characters and output and state report width to be 80 characters
- +3 ; Input and state report width to be 80 characters
- +4 ; ZTQUEUED - Queued flag
- +5 ; STARTDT - Start date for new filtering criteria
- +6 ; ENDDT - End date for new filtering criteria
- +7 ;
- +8 ; Output and state report width to be 80 characters
- +9 ; ZTSTOP - Flag for stopping routine
- +10 ;
- +11 ; IB*2.0*549 - Add DATA and SUBSCRIPT variables and alphabetize variables
- +12 ; IB*2.0*549 - Enables filtering of dates, includes last verified date
- +13 ; LSTVERDT - Last verified date
- +14 ;
- +15 NEW A,APPT,APTDTE,CNT,DATA,DFN,DPT,GRP,IBNEXT,INS,INSNM,LSTVERDT,MS,PLN
- +16 NEW PLNTYP,PTNM,RTN,SORT,SSN,SUBSCRIPT,X
- +17 SET RTN="IBCEMMR"
- +18 ; IB*2.0*528 - Add IBNEXT subscript to be initialized
- +19 FOR X=RTN,"IBCEPT","IBSDNEXT","IBDPT","IBNEXT","IBLAST"
- KILL ^TMP($JOB,X)
- +20 SET DFN=" "
- SET CNT=0
- +21 FOR
- SET DFN=$ORDER(^DPT(DFN),-1)
- if 'DFN!($GET(ZTSTOP))
- QUIT
- Begin DoDot:1
- +22 SET CNT=CNT+1
- +23 IF '$DATA(ZTQUEUED)
- IF CNT#500=0
- USE IO(0)
- WRITE "."
- USE IO
- +24 IF $DATA(ZTQUEUED)
- IF CNT#500=0
- IF $$S^%ZTLOAD()
- SET ZTSTOP=1
- QUIT
- +25 ; date of death
- IF $PIECE($GET(^DPT(DFN,.35)),U,1)
- QUIT
- +26 ; eligible for report
- IF '$$PTINS(DFN,.MS)
- QUIT
- +27 SET ^TMP($JOB,"IBNEXT",DFN)=""
- +28 SET ^TMP($JOB,"IBLAST",DFN)=""
- +29 SET ^TMP($JOB,"IBDPT",DFN)=""
- End DoDot:1
- +30 ;
- +31 SET X=$$NEXT^IBSDU("^TMP($J,""IBNEXT"",")
- +32 SET X=$$LAST^IBSDU("^TMP($J,""IBLAST"",")
- +33 ;
- +34 SET DFN=0
- +35 FOR
- SET DFN=$ORDER(^TMP($JOB,"IBDPT",DFN))
- if 'DFN!($GET(ZTSTOP))
- QUIT
- Begin DoDot:1
- +36 IF '$DATA(ZTQUEUED)
- IF CNT#500=0
- USE IO(0)
- WRITE "."
- USE IO
- +37 IF $DATA(ZTQUEUED)
- IF CNT#500=0
- IF $$S^%ZTLOAD()
- SET ZTSTOP=1
- QUIT
- +38 ; get MS data
- IF '$$PTINS(DFN,.MS)
- +39 SET DPT=$GET(^DPT(DFN,0))
- +40 SET PTNM=$PIECE(DPT,U,1)
- +41 IF PTNM=""
- SET PTNM="~UNKNOWN"
- +42 SET SSN=$EXTRACT($PIECE(DPT,U,9),6,99)_" "
- +43 if SSN=" "
- SET SSN="~UNK"
- +44 ; IB*2.0*549 - Change default value to empty string
- +45 SET (APPT,IBNEXT)=$GET(^TMP($JOB,"IBNEXT",DFN))
- +46 IF 'APPT
- SET APPT=$GET(^TMP($JOB,"IBLAST",DFN))
- +47 ;
- +48 ; IB*2.0*549 - Simplify $S assignment with $$GETAPDT
- +49 SET APTDTE=$$GETAPDT(APPT,IBNEXT)
- +50 ; IB*2.0*549 - Delete non-day portion of APPT
- +51 SET APPT=APPT\1
- +52 ; IB*2.0*549 FILTER BASED ON START DATE AND END DATE
- +53 if APTDTE="N/A"!(APPT<STARTDT)!(APPT>ENDDATE)
- QUIT
- +54 SET A=0
- +55 FOR
- SET A=$ORDER(MS(A))
- if 'A
- QUIT
- Begin DoDot:2
- +56 SET INS=+$PIECE(MS(A),U,1)
- SET GRP=+$PIECE(MS(A),U,2)
- +57 SET PLN=+$PIECE(MS(A),U,3)
- +58 SET INSNM=$PIECE($GET(^DIC(36,INS,0)),U,1)
- +59 IF INSNM=""
- SET INSNM="~UNKNOWN"
- +60 SET PLNTYP=$PIECE($GET(^IBE(355.1,PLN,0)),U,1)
- +61 IF PLNTYP=""
- SET PLNTYP="~UNKNOWN"
- +62 ; IB*2.0*549 - Simplify $S assignment
- +63 SET SORT=$$GETIBMST(IBMSORT,PTNM,SSN,INSNM,PLNTYP)
- +64 ; IB*2.0*549 Primary sort order by Last Appointment Date with
- +65 ; most recent date at top. Data includes Last
- +66 ; Verified Date.
- +67 SET LSTVERDT=$$GET1^DIQ(2.312,A_","_DFN_",",1.03,"I")
- +68 SET LSTVERDT=$$FMTE^XLFDT(LSTVERDT,"2DZ")
- +69 SET DATA=SSN_U_INSNM_U_PLNTYP_U_APTDTE_U_LSTVERDT
- +70 SET ^TMP($JOB,RTN,-APPT,SORT,PTNM,DFN,A)=DATA
- +71 ; IB*2.0*549 Delete trailing quits
- End DoDot:2
- End DoDot:1
- +72 ;
- +73 ; print the report
- IF '$GET(ZTSTOP)
- DO PRINT
- +74 ; close the device
- DO ^%ZISC
- +75 ; IB*2.0*528 Add IBNEXT subscript to be cleaned up
- +76 FOR SUBSCRIPT=RTN,"IBCEPT","IBSDNEXT","IBDPT","IBNEXT","IBLAST"
- KILL ^TMP($JOB,SUBSCRIPT)
- +77 ; purge the task record
- IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- COMPX ;
- +1 QUIT
- +2 ;
- +3 ; IB*2.0*549 Simplify setting of APTDTE from $S
- GETAPDT(APPT,IBNEXT) ; Get APTDTE from APPT/IBNEXT
- +1 ; Input and state report width to be 80 characters
- +2 ; APPT - Appointment date (external format)
- +3 ; IBNEXT - Next appointment date
- +4 ; Output and state report width to be 80 characters
- +5 ; APTDTE - Appointment date (external format)
- +6 ;
- +7 NEW APTDTE
- +8 ; Simplification of $S
- Begin DoDot:1
- +9 IF APPT
- SET APTDTE=$$FMTE^XLFDT($PIECE(APPT,"."),"2Z")
- QUIT
- +10 IF $LENGTH(IBNEXT)
- SET APTDTE=IBNEXT
- QUIT
- +11 IF $LENGTH(APPT)
- SET APTDTE=APPT
- QUIT
- +12 SET APTDTE="N/A"
- End DoDot:1
- +13 QUIT APTDTE
- +14 ;
- +15 ; IB*2.0*549 Simplify setting of SORT from $S
- GETIBMST(IBMSORT,PTNM,SSN,INSNM,PLNTYP) ; Get SORT from PTNM/SSN/INSNM/PLNTYP
- +1 ; Input and state report width to be 80 characters
- +2 ; IBMSORT - Sort choice index
- +3 ; PTNM - Patient name
- +4 ; SSN - SSN
- +5 ; INSNM - Insurance name
- +6 ; PLNTYP - Plan type
- +7 ; Output and state report width to be 80 characters
- +8 ; SORT - Secondary sort for report
- +9 ;
- +10 NEW SORT
- +11 ; IB*2.0*549 Secondary sort does not include Last Appointment
- +12 ; Date
- +13 ; Simplification of $S
- Begin DoDot:1
- +14 IF IBMSORT=1
- SET SORT=PTNM
- QUIT
- +15 IF IBMSORT=2
- SET SORT=SSN
- QUIT
- +16 IF IBMSORT=3
- SET SORT=INSNM
- QUIT
- +17 IF IBMSORT=4
- SET SORT=PLNTYP
- QUIT
- +18 SET SORT=PTNM
- End DoDot:1
- +19 QUIT SORT
- +20 ;
- PRINT ; print the report to the device specified
- +1 ; IB*2.0*549 APTDTE - Last appointment date (Primary sort criteria)
- +2 ; Add APTDTE/DTOUT/DUOUT and alphabetize variables
- +3 ; Add DF for data found
- +4 NEW A,APTDTE,CRT,DATA,DF,DFN,DIR,DIROUT,DIRUT,DTOUT,DUOUT,IBX,MAXCNT,PAGECNT,PTNM
- +5 NEW SORT,STOP,X,Y
- +6 ; IB*2.0*549 APTDTE - Last appointment date (Primary sort criteria)
- +7 SET APTDTE=""
- +8 ;
- +9 IF IOST["C-"
- SET MAXCNT=IOSL-3
- SET CRT=1
- +10 IF '$TEST
- SET MAXCNT=IOSL-6
- SET CRT=0
- +11 ; IB*2.0*549 Long screen length for Excel
- IF IBCEEXCEL
- SET IOSL=999999
- +12 ; output and state report width to be 80 characters
- +13 SET PAGECNT=0
- SET STOP=0
- +14 ;
- +15 ; IB*2.0*549 Handle no data found in better fashion
- +16 IF '$DATA(^TMP($JOB,RTN))
- Begin DoDot:1
- +17 SET DF=0
- +18 DO HEADER
- +19 WRITE !!?5,"No Data Found"
- End DoDot:1
- +20 ;
- +21 ; IB*2.0*549 for Excel CSV, display the header line first before looping
- +22 ; Handle for instances where there is data found
- +23 IF '$TEST
- Begin DoDot:1
- +24 SET DF=1
- +25 IF IBCEEXCEL
- WRITE !
- DO HEADER
- if STOP
- QUIT
- +26 ;
- +27 DO PRINT2(.STOP)
- End DoDot:1
- +28 if STOP
- QUIT
- +29 WRITE !!?30,"*** End of Report ***"
- +30 ; IB*2.0*549 Where data is found
- +31 IF DF
- IF CRT
- IF '$DATA(ZTQUEUED)
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- PRINTX ;
- +1 QUIT
- +2 ;
- PRINT2(STOP) ; Rest of Print tag
- +1 ; IB*2.0*549 Put loops in new tag
- +2 ; IB*2.0*549 Incorporate new primary sort criteria
- +3 SET APTDTE=""
- +4 FOR
- SET APTDTE=$ORDER(^TMP($JOB,RTN,APTDTE))
- if APTDTE=""
- QUIT
- Begin DoDot:1
- +5 SET SORT=""
- +6 FOR
- SET SORT=$ORDER(^TMP($JOB,RTN,APTDTE,SORT))
- if SORT=""
- QUIT
- Begin DoDot:2
- +7 SET PTNM=""
- +8 FOR
- SET PTNM=$ORDER(^TMP($JOB,RTN,APTDTE,SORT,PTNM))
- if PTNM=""
- QUIT
- Begin DoDot:3
- +9 SET DFN=0
- +10 FOR
- SET DFN=$ORDER(^TMP($JOB,RTN,APTDTE,SORT,PTNM,DFN))
- if 'DFN
- QUIT
- Begin DoDot:4
- +11 SET A=0
- +12 FOR
- SET A=$ORDER(^TMP($JOB,RTN,APTDTE,SORT,PTNM,DFN,A))
- if 'A
- QUIT
- Begin DoDot:5
- +13 SET DATA=$GET(^TMP($JOB,RTN,APTDTE,SORT,PTNM,DFN,A))
- +14 ; IB*2.0*549 for Excel output and state report width to be 80 characters, print a CSV format record
- +15 IF IBCEEXCEL
- DO EXCELN(PTNM,DATA)
- QUIT
- +16 ;
- +17 IF $Y+1>MAXCNT!'PAGECNT
- DO HEADER
- if STOP
- QUIT
- +18 ; IB*2.0*549 Add new field (Last Verified Date)
- +19 WRITE !,$EXTRACT(PTNM,1,16),?19,$PIECE(DATA,U,1),?26,$EXTRACT($PIECE(DATA,U,2),1,17)
- +20 WRITE ?45,$EXTRACT($PIECE(DATA,U,3),1,12),?59,$PIECE(DATA,U,4),?69,$PIECE(DATA,U,5)
- End DoDot:5
- if STOP
- QUIT
- End DoDot:4
- if STOP
- QUIT
- End DoDot:3
- if STOP
- QUIT
- End DoDot:2
- if STOP
- QUIT
- End DoDot:1
- if STOP
- QUIT
- +21 QUIT
- +22 ;
- EXCELN(PTNM,DATA) ; IB*2.0*549 output and state report width to be 80 characters one Excel line
- +1 ; Input and state report width to be 80 characters
- +2 ; PTNM - Patient name
- +3 ; DATA - Report data
- +4 ;
- +5 NEW IBZ
- +6 ; patient name
- SET IBZ=$$CSV("",PTNM)
- +7 ; SSN (Keeps leading zeroes)
- SET IBZ=$$CSV(IBZ,$PIECE(DATA,U,1))
- +8 ; insurance company
- SET IBZ=$$CSV(IBZ,$PIECE(DATA,U,2))
- +9 ; type of plan
- SET IBZ=$$CSV(IBZ,$PIECE(DATA,U,3))
- +10 ; appointment date
- SET IBZ=$$CSV(IBZ,$PIECE(DATA,U,4))
- +11 ; last verified date
- SET IBZ=$$CSV(IBZ,$PIECE(DATA,U,5))
- +12 WRITE !,IBZ
- +13 QUIT
- +14 ;
- +1 ; IB*2.0*549 Add DIR/DIROUT/DIRUT/DTOUT/DUOUT
- +2 ;
- +3 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,HDR,LIN,TAB
- +4 SET STOP=0
- +5 ; ask screen user if they want to continue
- +6 IF CRT
- IF PAGECNT>0
- IF '$DATA(ZTQUEUED)
- Begin DoDot:1
- +7 IF MAXCNT<51
- FOR LIN=1:1:(MAXCNT-$Y)
- WRITE !
- +8 SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- +9 IF 'Y
- SET STOP=1
- QUIT
- +10 ; IB*2.0*549 Delete trailing quits
- End DoDot:1
- if STOP
- QUIT
- +11 ;
- +12 SET PAGECNT=PAGECNT+1
- +13 ; IB*2.0*549 *** Enable printing to delimited file ***
- +14 ; IB*2.0*549 For Excel CSV format, display all headers
- IF IBCEEXCEL
- DO EXCELHD(ENDDATE,IBMSORT,STARTDT)
- QUIT
- +15 ;
- +16 WRITE @IOF,!,"Patients Without MEDICARE (WNR) Insurance"
- +17 SET HDR="Page: "_PAGECNT
- +18 SET TAB=80-$LENGTH(HDR)-1
- +19 WRITE ?TAB,HDR
- +20 ; IB*2.0*549 Appointment Date no longer Secondary Sort option
- +21 WRITE !,"Sorted by Appt, ",$SELECT(IBMSORT=1:"Patient Name",IBMSORT=2:"SSN - Last 4 Digits",IBMSORT=3:"Insurance Company",IBMSORT=4:"Type of Plan",1:"Patient Name")
- +22 SET HDR=$$FMTE^XLFDT($$NOW^XLFDT,"1Z")
- +23 SET TAB=80-$LENGTH(HDR)-1
- +24 WRITE ?TAB,HDR
- +25 WRITE !,"Appointment Dates: ",$$CNVTDT(STARTDT)," - ",$$CNVTDT(ENDDATE)
- +26 ; IB*2.0*549 Added blank line before column headers
- +27 WRITE !!,"Patient Name",?20,"SSN",?26,"Insurance Company"
- +28 ; IB*2.0*549 Add new field (Last Verified Date)
- +29 WRITE ?45,"Type of Plan",?59,"ApptDate",?69,"LstVerDt"
- +30 WRITE !,$$RJ^XLFSTR("",80,"=")
- +31 ;
- +32 ; check for stop request
- +33 IF $DATA(ZTQUEUED)
- IF $$S^%ZTLOAD()
- Begin DoDot:1
- +34 SET (ZTSTOP,STOP)=1
- +35 WRITE !!!?5,"*** Report Halted by TaskManager Request ***"
- +36 ; IB*2.0*549 Delete trailing quits
- End DoDot:1
- QUIT
- +37 ;
- +1 QUIT
- +2 ;
- CNVTDT(DATE) ; IB*2.0*549 Convert from VA internal date to MM/DD/YY
- +1 NEW DAY,MON,YR
- +2 SET YR=(17+$EXTRACT(DATE))_$EXTRACT(DATE,2,3)
- SET MON=$EXTRACT(DATE,4,5)
- SET DAY=$EXTRACT(DATE,6,7)
- +3 QUIT MON_"/"_DAY_"/"_YR
- +4 ;
- EXCELHD(ENDDATE,IBMSORT,STARTDT) ; IB*2.0*549 print an Excel CSV header record (only 1 Excel CSV header
- +1 ; should print for the whole report)
- +2 ; IB*2.0*549 - Added code to enhance report header and simplify setting of IBMSORT
- +3 NEW IBH,IBHDT,STR
- +4 DO NOW^%DTC
- +5 SET IBHDT=$$DAT2^IBOUTL($EXTRACT(%,1,12))
- +6 WRITE !,"Patients Without MEDICARE (WNR) Insurance",?53,"Run On: ",IBHDT
- +7 WRITE !,"Sorted by Appt, "
- +8 Begin DoDot:1
- +9 IF IBMSORT=1
- WRITE "Patient Name"
- QUIT
- +10 IF IBMSORT=2
- WRITE "SSN - Last 4 Digits"
- QUIT
- +11 IF IBMSORT=3
- WRITE "Insurance Company"
- QUIT
- +12 IF IBMSORT=4
- WRITE "Type of Plan"
- QUIT
- +13 WRITE "Patient Name"
- End DoDot:1
- +14 WRITE !,"Appointment Dates: ",$$CNVTDT(STARTDT)," - ",$$CNVTDT(ENDDATE)
- +15 SET IBH="Patient Name"
- +16 FOR STR="SSN","Insurance Company","Type of Plan","ApptDate","LstVerDt"
- SET IBH=IBH_U_STR
- +17 WRITE !!,IBH
- +18 QUIT
- +19 ;
- CSV(STRING,DATA) ; IB*2.0*549 build the Excel data string for CSV format
- +1 ; Input and state report width to be 80 characters
- +2 ; STRING - Excel data string being added on to
- +3 ; DATA - Data to be added to string
- +4 ; Output and state report width to be 80 characters
- +5 ; STRING - Data string which was added to
- +6 ;
- +7 SET DATA=$TRANSLATE(DATA,U,"?")
- +8 SET STRING=$SELECT(STRING="":DATA,1:STRING_U_DATA)
- +9 QUIT STRING
- +10 ;
- PTINS(DFN,MCRSUP) ; Function to determine if a patient should be
- +1 ; included in this report or not.
- +2 ; Input and state report width to be 80 characters: DFN - patient ien
- +3 ; Output and state report width to be 80 characters: Function value is either 0 (don't include) or 1 (include)
- +4 ; MCRSUP array pass by reference
- +5 ; MCRSUP(seq) = [1] insurance co ien pointer to file 36
- +6 ; [2] group pointer to file 355.3
- +7 ; [3] type of plan pointer to file 355.1
- +8 ;
- +9 ;IB*2.0*549 Abbreviate NEW to N and alphabetize variables
- +10 NEW A,GP,IBGRP,IBINS,INCLUDE,INS,MCRWNR,MCRZ,PLABBR,TP
- +11 SET INCLUDE=0
- KILL MCRSUP
- +12 IF '$GET(DFN)
- GOTO PTINSX
- +13 IF '$DATA(^DPT(DFN))
- GOTO PTINSX
- +14 DO ALLWNR^IBCNS1(DFN,"INS",DT)
- +15 SET A=0
- SET (MCRWNR,MCRZ)=0
- +16 FOR
- SET A=$ORDER(INS(A))
- if 'A
- QUIT
- Begin DoDot:1
- +17 SET IBINS=$PIECE($GET(INS(A,0)),U,1)
- +18 SET IBGRP=$PIECE($GET(INS(A,0)),U,18)
- +19 ; Medicare WNR on file
- IF $$MCRWNR^IBEFUNC(IBINS)
- SET MCRWNR=1
- QUIT
- +20 ; group/plan info
- SET GP=$GET(INS(A,355.3))
- +21 ; type of plan pointer
- SET TP=$PIECE(GP,U,9)
- SET PLABBR=""
- +22 ; plan abbreviation
- IF TP
- SET PLABBR=$PIECE($GET(^IBE(355.1,TP,0)),U,2)
- +23 ; check plan
- IF '$FIND(".MG.MS.COUT.","."_PLABBR_".")
- QUIT
- +24 ; Medicare other on file
- SET MCRZ=1
- +25 SET MCRSUP(A)=IBINS_U_IBGRP_U_TP
- +26 ; IB*2.0*549 Delete trailing quits
- End DoDot:1
- if MCRWNR
- QUIT
- +27 ;
- +28 ; If Medicare Other was found, but no Medicare WNR, then include it
- +29 IF MCRZ
- IF 'MCRWNR
- SET INCLUDE=1
- +30 ;
- PTINSX ;
- +1 IF 'INCLUDE
- KILL MCRSUP
- +2 QUIT INCLUDE
- +3 ;
- +4 ; IB*2.0*549 Add STARTDT, ENDDATE and IBCEEXCEL arguments to pass to
- +5 ; DEVICE tag
- DEVICE(STARTDT,ENDDATE,IBCEEXCEL) ; This procedure displays a warning message
- +1 ; AND prompts for the device on which to
- +2 ; print the report.
- +3 ;
- +4 ;IB*2.0*549 Add DIR/DIROUT/DIRUT/DTOUT/DUOUT
- +5 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,POP,ZTDESC,ZTRTN,ZTSAVE
- +6 ; IB*2.0*549 Allow for CSV output and state report width to be 80 characters
- +7 IF 'IBCEEXCEL
- Begin DoDot:1
- +8 WRITE !!,"This report is 80 characters wide. "
- +9 WRITE "Please choose an appropriate device.",!
- End DoDot:1
- +10 IF '$TEST
- Begin DoDot:1
- +11 WRITE !!,"For CSV output and state report width to be 80 characters, turn logging or capture on now."
- +12 WRITE !,"To avoid undesired wrapping of the data saved to the file,"
- +13 WRITE !,"please enter ""0;256;99999"" at the ""DEVICE:"" prompt.",!
- End DoDot:1
- +14 ;
- +15 WRITE *7,!!!?14,"*** WARNING ***"
- +16 WRITE !?2,"This report takes a long time to compile!"
- +17 WRITE !!?2,"The active insurance coverage for all living patients is analyzed."
- +18 WRITE !!?2,"It is recommended that you queue this report to the background and"
- +19 WRITE !?2,"run it after hours or on the weekend."
- +20 WRITE !!?2,"This report is 80 characters wide."
- +21 WRITE !
- +22 ;
- +23 SET ZTRTN="COMPILE^IBCEMMR"
- +24 SET ZTDESC="Patients without MEDICARE (WNR) Insurance"
- +25 SET ZTSAVE("IBMSORT")=""
- +26 ; IB*2.0*549 Add code to save STARTDT, ENDDATE and IBCEEXCEL
- +27 SET ZTSAVE("STARTDT")=""
- +28 SET ZTSAVE("ENDDATE")=""
- +29 SET ZTSAVE("IBCEEXCEL")=""
- +30 ; IB*2.0*549 Enable report to choose a file in delimited format
- +31 DO EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE,"QM",1)
- +32 IF $GET(ZTSK)
- Begin DoDot:1
- +33 WRITE !!,"Report compilation has started with task# ",ZTSK,".",!
- +34 SET DIR(0)="E"
- DO ^DIR
- End DoDot:1
- DEVICEX ;
- +1 QUIT
- +2 ;