FBARCHR0 ; HINOIFO/BNT - ARCH Reports ; 05/09/11 5:30pm
;;3.5;FEE BASIS;**130**;JAN 30, 1995;Build 13
;;Per VHA Directive 2004-038, this routine should not be modified.
;Integration Agreements:
;
Q
;
;
SELSMDET(DFLT) ; Display (S)ummary or (D)etail Format
; Input Variable -> DFLT = 1 Summary
; 2 Detail
;
; Return Value -> 1 = Summary
; 0 = Detail
; ^ = Exit
;
N DIR,DIRUT,DTOUT,DUOUT,X,Y
S DFLT=$S($G(DFLT)=1:"Summary",$G(DFLT)=0:"Detail",1:"Detail")
S DIR(0)="S^S:Summary;D:Detail",DIR("A")="Display (S)ummary or (D)etail Format",DIR("B")=DFLT
D ^DIR
I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
S Y=$S(Y="S":1,Y="D":0,1:Y)
Q Y
;
SELEXCEL() ; - Returns whether to capture data for Excel report.
; Output: EXCEL = 1 - YES (capture data) / 0 - NO (DO NOT capture data)
;
N EXCEL,DIR,DIRUT,DTOUT,DUOUT,DIROUT
;
S DIR(0)="Y",DIR("B")="NO",DIR("T")=DTIME W !
S DIR("A")="Do you want to capture report data for an Excel document"
S DIR("?")="^D HEXC^FBARCHR0"
D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q "^"
K DIROUT,DTOUT,DUOUT,DIRUT
S EXCEL=0 I Y S EXCEL=1
;
;Display Excel display message
I EXCEL=1 D EXMSG
;
Q EXCEL
;
SELPAT(DFLT) ; - Returns either a Fee Basis Patient IEN or 0 for All patients
N DIR,DIRUT,DTOUT,DUOUT,X,Y
S DFLT=$S($G(DFLT)=1:"One Patient",$G(DFLT)=0:"All Patients",1:"All Patients")
S DIR(0)="S^P:One Patient;A:All Patients",DIR("A")="Display One (P)atient or (A)ll Patients",DIR("B")=DFLT
D ^DIR
I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
S Y=$S(Y="P":1,Y="A":0,1:Y)
I Y D
. N DIR,DIRUT,DTOUT,DUOUT
. ;Prompt to select FEE BASIS PATIENT file entry
. S DIR(0)="P^161:EMZ",DIR("S")="I $D(^FBAAA(Y,""ARCHFEE"",0))"
. D ^DIR I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
. I +Y S Y=+Y
Q Y
;
SELDATE(DFLT) ; Select Date Range
; Input Variable -> DFLT = 1 - ARCH Eligibility Date
; 0 - All Dates
;
; Return Value -> P1^P2
;
; where P1 = From Date
; = ^ Exit
; P2 = To Date
; = blank for Exit
;
N DIR,DIRUT,DTOUT,DUOUT,VAL,X,Y
S DFLT=$S($G(DFLT)=1:"ARCH Eligibility Date",$G(DFLT)=0:"All",1:"All")
S DIR(0)="S^D:ARCH Eligibility Date;A:All",DIR("A")="Select a beginning ARCH Eligibility (D)ate or (A)ll",DIR("B")=DFLT
D ^DIR
I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
S Y=$S(Y="D":1,Y="A":0,1:Y)
I Y'=1 Q Y
;
S VAL="",DIR(0)="DA^:DT:EX",DIR("A")="Beginning ARCH Eligibility Date: ",DIR("B")="SEP 30, 2010"
W ! D ^DIR
;
;Check for "^", timeout, or blank entry
I ($G(DUOUT)=1)!($G(DTOUT)=1)!($G(X)="") S VAL="^"
;
I VAL="" D
.S $P(VAL,U)=Y
.S DIR(0)="DA^"_VAL_":DT:EX",DIR("A")=" Ending ARCH Eligibility Date: ",DIR("B")="T"
.D ^DIR
.;
.;Check for "^", timeout, or blank entry
.I ($G(DUOUT)=1)!($G(DTOUT)=1)!($G(X)="") S VAL="^" Q
.;
.;Define Entry
.S $P(VAL,U,2)=Y
;
Q VAL
;
SELELIG(DFLT) ; Select ARCH Eligibility Status
; Input Variable -> DFLT = 0 - NO patient is not ARCH eligible
; 1 - YES patient is ARCH eligible
; 2 - BOTH
;
; Return Value -> 0 - NO patient is not ARCH eligible
; 1 - YES patient is ARCH eligible
; 2 - BOTH
; ^ - EXIT
;
N DIR,DIRUT,DTOUT,DUOUT,X,Y
S DFLT=$S($G(DFLT)=0:"NO",$G(DFLT)=1:"YES",1:"BOTH")
S DIR(0)="S^Y:YES - Patient is ARCH Eligible;N:NO - Patient is NOT ARCH Eligible;B:BOTH",DIR("A")="Which ARCH Eligibility Status should display (Y/N/B)",DIR("B")=DFLT
D ^DIR
I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
S Y=$S(Y="N":0,Y="Y":1,Y="B":2,1:Y)
Q Y
;
SELELDET(DFLT) ; Select ARCH Eligibility Determination
; Input Variable -> DFLT = 0 - CAC
; 1 - SAS DB Update
; 2 - All
;
; Return Value -> New Person File IEN of CAC
; -1 - SAS DB Update
; 0 - All
; ^ - EXIT
;
N DIR,DIRUT,DTOUT,DUOUT,X,Y
S DFLT=$S($G(DFLT)=0:"U",$G(DFLT)=1:"N",1:"A")
S DIR(0)="S^C:Project ARCH CAC;S:SAS DB Update;A:All",DIR("A")="Select ARCH Elig Determination (C)AC, (S)AS DB update or (A)LL",DIR("B")=DFLT
D ^DIR
I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
S Y=$S(Y="C":1,Y="S":0,Y="A":-1,1:Y)
I Y=1 D
. N DIR,DIRUT,DTOUT,DUOUT
. ;Prompt to select NEW PERSON file entry. Screen on ELIGIBILITY SOURCE
. S DIR(0)="P^200:EMZ",DIR("S")="I $D(^FBAAA(""ARCHSRC"",Y))"
. S DIR("A")="Select Project ARCH CAC"
. D ^DIR I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
. S Y=+Y
Q Y
;
SELJUST() ; Select the ARCH Justification Reason
; Return Value -> FEE BASIS PROJECT ARCH JUSTIFICATION file #161.35 IEN
;
N FBJUST,IEN,X,CNT,FBJAR,DIR,DTOUT,DUOUT,Y
S (FBJUST,X,CNT)=0
W !!," Project ARCH Justification Reasons",!
F S FBJUST=$O(^FBAA(161.35,"C",FBJUST)) Q:FBJUST="" D
. S IEN=$O(^FBAA(161.35,"C",FBJUST,0))
. Q:$P(^FBAA(161.35,IEN,0),U,2)'=1
. S CNT=CNT+1
. S FBJAR(CNT)=FBJUST_U_IEN
F S X=$O(FBJAR(X)) Q:X="" D
. W !,?5,X
. I $L($P(FBJAR(X),U))>69 D
. . ; Handle the line breaks and hyphenate the word in the right spot
. . I $E($P(FBJAR(X),U),70)'=" " D Q
. . . W ?10,$E($P(FBJAR(X),U),1,69),"-"
. . . W !,?10,$E($P(FBJAR(X),U),70,$L($P(FBJAR(X),U)))
. . W ?10,$E($P(FBJAR(X),U),1,70)
. . W !,?10,$E($P(FBJAR(X),U),71,$L($P(FBJAR(X),U)))
W !
S DIR(0)="N^1:"_CNT,DIR("A")="Select ARCH Justification" D ^DIR
I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^" Q Y
W " ",$P(FBJAR(Y),U),!
Q $P(FBJAR(Y),U,2)
;
HEXC ; - 'Do you want to capture data...' prompt
W !!," Enter: 'Y' - To capture detail report data to transfer"
W !," to an Excel document"
W !," '<CR>' - To skip this option"
W !," '^' - To quit this option"
Q
;
;Display the message about capturing to an Excel file format
;
EXMSG ;
W !!?5,"Before continuing, please set up your terminal to capture the"
W !?5,"detail report data. On some terminals, this can be done by"
W !?5,"clicking on the 'Tools' menu above, then click on 'Capture"
W !?5,"Incoming Data' to save to Desktop. This report may take a"
W !?5,"while to run."
W !!?5,"Note: To avoid undesired wrapping of the data saved to the"
W !?5," file, please enter '0;256;999' at the 'DEVICE:' prompt.",!
Q
;
;Screen Pause 1
;
; Return variable - FBQ = 0 Continue
; 2 Quit
PAUSE N X
U IO(0) W !!,"Press RETURN to continue, '^' to exit:"
R X:$G(DTIME) S:'$T X="^" S:X["^" FBQ=2
U IO
Q
;
;Screen Pause 2
;
; Return variable - FBQ = 0 Continue
; 2 Quit
PAUSE2 N X
U IO(0) W !!,"Press RETURN to continue:"
R X:$G(DTIME) S:'$T X="^" S:X["^" FBQ=2
U IO
Q
;
CHKKEY(KEY) ; Check if user holds the appropriate security key
; Return 1 if user holds key, 0 if not and display message
Q:KEY']"" 0
I $D(^XUSEC(KEY,DUZ)) Q 1
W !,"You must hold the "_KEY_" Security Key in order to continue."
D PAUSE2
Q 0
;
REPORT(REF,FBEXCEL,FBSCR,FBRPTNAM,FBPAT,FBBEGDT,FBENDDT,FBELIG,FBELDET,FBSUMDET,FBPAGE) ; Display the report
N DFN,ELIGDT,DETUSR,FB11,ELIGIND,FBARCH0,FBCNT
N NP,FBLOCNT,FBNCNT,FBNELCNT,FBNPAT,FBELPAT
S (FBLOCNT,FBNCNT,FBNELCNT,FBCNT)=0
D HDR(FBRPTNAM,.FBPAGE)
I '$D(@REF) W !,"No data meets the criteria." G XREPORT
;
S DFN="" F S DFN=$O(@REF@(DFN)) Q:DFN="" D Q:FBQ
. Q:'$D(^DPT(DFN))
. ; Check the patient filter
. I FBPAT Q:DFN'=FBPAT
. S FBNPAT=1
. S ELIGDT="" F S ELIGDT=$O(@REF@(DFN,ELIGDT)) Q:ELIGDT="" D Q:FBQ
. . ; Check the date filters
. . I FBBEGDT,ELIGDT<FBBEGDT Q
. . S FB11="" F S FB11=$O(@REF@(DFN,ELIGDT,FB11)) Q:FB11="" D Q:FBQ
. . . S FBARCH0=^FBAAA(DFN,"ARCHFEE",FB11,0)
. . . S ELIGIND=$P(FBARCH0,U,2)
. . . S DETUSR=$S($P(FBARCH0,U,3)]"":$P(^VA(200,$P(FBARCH0,U,3),0),U),1:"SAS DB UPDATE")
. . . ; Check the Eligibility filter
. . . I FBELIG'=2,FBELIG'=ELIGIND Q
. . . ; Check Determination Source filter
. . . I FBELDET>0,FBELDET'=$P(FBARCH0,U,3) Q
. . . I FBELDET=0,$P(FBARCH0,U,3)]"" Q
. . . ; Set eligibility counter
. . . S FBELPAT(DFN)=$S((ELIGIND)&($P(FBARCH0,U,3)]""):1,(ELIGIND)&($P(FBARCH0,U,3)=""):2,1:0)
. . . I FBNPAT S FBCNT=FBCNT+1
. . . S NP=$$CHKP(1) Q:FBQ
. . . I 'FBSUMDET D
. . . . D WRLINE1(FBEXCEL,$S(FBNPAT:FBCNT,1:""),$P(^DPT(DFN,0),U),ELIGDT,ELIGIND,DETUSR)
. . . . I $P(FBARCH0,U,4)]"" D WRLINE2(FBEXCEL,$P(FBARCH0,U,4))
. . . . I $P(FBARCH0,U,5)]"" D WRLINE3(FBEXCEL,$P(FBARCH0,U,5))
. . . ; Reset FBNPAT to not print the ID if same patient
. . . S FBNPAT=0
Q:FBQ
; Get the total eligible patients
N DFN S DFN="" F S DFN=$O(FBELPAT(DFN)) Q:DFN="" D
. ; Get locally defined eligible patients
. I FBELPAT(DFN)=1 S FBLOCNT=FBLOCNT+1 Q
. ; Get nationally defined eligible patients
. I FBELPAT(DFN)=2 S FBNCNT=FBNCNT+1 Q
. ; Get locally defined patients changed to Not Eligible
. S FBNELCNT=FBNELCNT+1
W !
I (FBELIG=1)!(FBELIG=2) W !,"Total Nationally Determined Project ARCH Eligible Patients: "_FBNCNT
I (FBELIG=1)!(FBELIG=2) W !,"Total Locally Determined Project ARCH Eligible Patients: "_FBLOCNT
I (FBELIG=0)!(FBELIG=2) W !,"Total Locally Determined Eligible changed to Not Eligible: "_FBNELCNT
Q
;
WRLINE1(FBEXCEL,ID,PATIENT,ELIGDT,ELIGIND,DETERM) ; Write Line 1 of report
I FBEXCEL W !,ID_U_PATIENT_U_$$FMTE^XLFDT(ELIGDT)_U_$S(ELIGIND=1:"YES",1:"NO")_U_DETERM Q
;
W !,ID,?8,PATIENT,?35,$$FMTE^XLFDT(ELIGDT),?51,$S(ELIGIND=1:"YES",1:"NO"),?64,DETERM
Q
;
WRLINE2(FBEXCEL,FBJUST) ; Write Line 2 of report
I FBEXCEL W U_$P(^FBAA(161.35,FBJUST,0),U) Q
;
W !,?10,$P(^FBAA(161.35,FBJUST,0),U)
Q
;
WRLINE3(FBEXCEL,FBMILE) ; Write Line 3 of report
I FBEXCEL W U_FBMILE Q
;
W !,?12,FBMILE
Q
;
;Check for End of Page
; Input variables -> FBLINES -> Number of lines from bottom
; FBEXCEL -> 1 - Print to Excel/0 Regular Display
; Output variable -> FBDATA -> 0 -> New screen, no data displayed yet
; 1 -> Data displayed on current screen
CHKP(FBLINES) Q:$G(FBEXCEL) 0
S FBLINES=FBLINES+1
I $G(FBSCR) S FBLINES=FBLINES+2
I $G(FBSCR),'$G(FBDATA) S FBDATA=1 Q 0
S FBDATA=1
I $Y>(IOSL-FBLINES) D:$G(FBSCR) PAUSE Q:$G(FBQ) 0 D HDR(FBRPTNAM,.FBPAGE) Q 1
Q 0
;
;Print one line of characters
ULINE(X) N I
W ! F I=1:1:80 W $G(X,"-")
Q
;
HDR(FBRPTNAM,FBPAGE) ;
;Display Excel Header
I FBEXCEL D EXHDR Q
;
; Define FBDATA - Tells whether data has been displayed for a screen
S FBDATA=0
S FBPAGE=$G(FBPAGE)+1
W @IOF
W FBRPTNAM_" ("_$S(FBSUMDET=1:"SUMMARY",1:"DETAIL")_" REPORT)"
W $$RJ("Page: "_FBPAGE,30)
W !,"Print Date: "_$G(FBNOW)
I +FBBEGDT W !,"Report Date From "_$$DATTIM(FBBEGDT)_" through "_$$DATTIM($P(FBENDDT,"."))
;
;
D ULINE("-") Q:$G(FBQ)
; If just printing Summary, no need to print other headers
I FBSUMDET Q
D HEADLN1
D HEADLN2
D HEADLN3
D ULINE("-")
;
Q
;
EXHDR ; Write the Excel Report Header
W !,"ID#"_U
W "PATIENT"_U
W "ELIG DATE"_U
W "ELIGIBLE"_U
W "DETERMINATION"_U
W "LOCAL JUSTIFICATION"_U
W "LOCAL VERIFICATION OF MILEAGE"_U
Q
;
DATTIM(X) ;Convert FM date or date.time to displayable (mm/dd/yy HH:MM) format
N DATE,FBT,FBM,FBH,FBAP
S DATE=$S(X:$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3),1:"")
S FBT=$P(X,".",2) S:$L(FBT)<4 FBT=FBT_$E("0000",1,4-$L(FBT))
S FBH=$E(FBT,1,2),FBM=$E(FBT,3,4)
S FBAP="AM" I FBH>12 S FBH=FBH-12,FBAP="PM" S:$L(FBH)<2 FBH="0"_FBH
I FBT S:'FBH FBH=12 S DATE=DATE_" "_FBH_":"_FBM_FBAP
Q $G(DATE)
;
HEADLN1 ; Write the first header line
W !,"ID#",?8,"Patient",?35,"Elig Date",?51,"Eligible",?64,"Determination"
Q
;
HEADLN2 ; Write the second header line
W !,?10,"Local Project ARCH Justification"
Q
;
HEADLN3 ; Write the third header line
W !,?12,"Local Verification of Mileage"
Q
;
XREPORT Q
;
;left justified, blank padded
;adds spaces on right or truncates to make return string FBLEN characters long
;FBST- original string
;FBLEN - desired length
LJ(FBST,FBLEN) ;
N FBL
S FBL=FBLEN-$L(FBST)
Q $E(FBST_$J("",$S(FBL<0:0,1:FBL)),1,FBLEN)
;
;right justified, blank padded
;adds spaces on left or truncates to make return string FBLEN characters long
;FBST- original string
;FBLEN - desired length
RJ(FBST,FBLEN) ;
S FBL=FBLEN-$L(FBST)
I FBL>0 Q $J("",$S(FBL<0:0,1:FBL))_FBST
Q $E(FBST,1,FBLEN)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBARCHR0 12662 printed Dec 13, 2024@01:57:19 Page 2
FBARCHR0 ; HINOIFO/BNT - ARCH Reports ; 05/09/11 5:30pm
+1 ;;3.5;FEE BASIS;**130**;JAN 30, 1995;Build 13
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;Integration Agreements:
+4 ;
+5 QUIT
+6 ;
+7 ;
SELSMDET(DFLT) ; Display (S)ummary or (D)etail Format
+1 ; Input Variable -> DFLT = 1 Summary
+2 ; 2 Detail
+3 ;
+4 ; Return Value -> 1 = Summary
+5 ; 0 = Detail
+6 ; ^ = Exit
+7 ;
+8 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+9 SET DFLT=$SELECT($GET(DFLT)=1:"Summary",$GET(DFLT)=0:"Detail",1:"Detail")
+10 SET DIR(0)="S^S:Summary;D:Detail"
SET DIR("A")="Display (S)ummary or (D)etail Format"
SET DIR("B")=DFLT
+11 DO ^DIR
+12 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)
SET Y="^"
+13 SET Y=$SELECT(Y="S":1,Y="D":0,1:Y)
+14 QUIT Y
+15 ;
SELEXCEL() ; - Returns whether to capture data for Excel report.
+1 ; Output: EXCEL = 1 - YES (capture data) / 0 - NO (DO NOT capture data)
+2 ;
+3 NEW EXCEL,DIR,DIRUT,DTOUT,DUOUT,DIROUT
+4 ;
+5 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("T")=DTIME
WRITE !
+6 SET DIR("A")="Do you want to capture report data for an Excel document"
+7 SET DIR("?")="^D HEXC^FBARCHR0"
+8 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT "^"
+9 KILL DIROUT,DTOUT,DUOUT,DIRUT
+10 SET EXCEL=0
IF Y
SET EXCEL=1
+11 ;
+12 ;Display Excel display message
+13 IF EXCEL=1
DO EXMSG
+14 ;
+15 QUIT EXCEL
+16 ;
SELPAT(DFLT) ; - Returns either a Fee Basis Patient IEN or 0 for All patients
+1 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+2 SET DFLT=$SELECT($GET(DFLT)=1:"One Patient",$GET(DFLT)=0:"All Patients",1:"All Patients")
+3 SET DIR(0)="S^P:One Patient;A:All Patients"
SET DIR("A")="Display One (P)atient or (A)ll Patients"
SET DIR("B")=DFLT
+4 DO ^DIR
+5 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)
SET Y="^"
+6 SET Y=$SELECT(Y="P":1,Y="A":0,1:Y)
+7 IF Y
Begin DoDot:1
+8 NEW DIR,DIRUT,DTOUT,DUOUT
+9 ;Prompt to select FEE BASIS PATIENT file entry
+10 SET DIR(0)="P^161:EMZ"
SET DIR("S")="I $D(^FBAAA(Y,""ARCHFEE"",0))"
+11 DO ^DIR
IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)
SET Y="^"
+12 IF +Y
SET Y=+Y
End DoDot:1
+13 QUIT Y
+14 ;
SELDATE(DFLT) ; Select Date Range
+1 ; Input Variable -> DFLT = 1 - ARCH Eligibility Date
+2 ; 0 - All Dates
+3 ;
+4 ; Return Value -> P1^P2
+5 ;
+6 ; where P1 = From Date
+7 ; = ^ Exit
+8 ; P2 = To Date
+9 ; = blank for Exit
+10 ;
+11 NEW DIR,DIRUT,DTOUT,DUOUT,VAL,X,Y
+12 SET DFLT=$SELECT($GET(DFLT)=1:"ARCH Eligibility Date",$GET(DFLT)=0:"All",1:"All")
+13 SET DIR(0)="S^D:ARCH Eligibility Date;A:All"
SET DIR("A")="Select a beginning ARCH Eligibility (D)ate or (A)ll"
SET DIR("B")=DFLT
+14 DO ^DIR
+15 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)
SET Y="^"
+16 SET Y=$SELECT(Y="D":1,Y="A":0,1:Y)
+17 IF Y'=1
QUIT Y
+18 ;
+19 SET VAL=""
SET DIR(0)="DA^:DT:EX"
SET DIR("A")="Beginning ARCH Eligibility Date: "
SET DIR("B")="SEP 30, 2010"
+20 WRITE !
DO ^DIR
+21 ;
+22 ;Check for "^", timeout, or blank entry
+23 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)!($GET(X)="")
SET VAL="^"
+24 ;
+25 IF VAL=""
Begin DoDot:1
+26 SET $PIECE(VAL,U)=Y
+27 SET DIR(0)="DA^"_VAL_":DT:EX"
SET DIR("A")=" Ending ARCH Eligibility Date: "
SET DIR("B")="T"
+28 DO ^DIR
+29 ;
+30 ;Check for "^", timeout, or blank entry
+31 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)!($GET(X)="")
SET VAL="^"
QUIT
+32 ;
+33 ;Define Entry
+34 SET $PIECE(VAL,U,2)=Y
End DoDot:1
+35 ;
+36 QUIT VAL
+37 ;
SELELIG(DFLT) ; Select ARCH Eligibility Status
+1 ; Input Variable -> DFLT = 0 - NO patient is not ARCH eligible
+2 ; 1 - YES patient is ARCH eligible
+3 ; 2 - BOTH
+4 ;
+5 ; Return Value -> 0 - NO patient is not ARCH eligible
+6 ; 1 - YES patient is ARCH eligible
+7 ; 2 - BOTH
+8 ; ^ - EXIT
+9 ;
+10 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+11 SET DFLT=$SELECT($GET(DFLT)=0:"NO",$GET(DFLT)=1:"YES",1:"BOTH")
+12 SET DIR(0)="S^Y:YES - Patient is ARCH Eligible;N:NO - Patient is NOT ARCH Eligible;B:BOTH"
SET DIR("A")="Which ARCH Eligibility Status should display (Y/N/B)"
SET DIR("B")=DFLT
+13 DO ^DIR
+14 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)
SET Y="^"
+15 SET Y=$SELECT(Y="N":0,Y="Y":1,Y="B":2,1:Y)
+16 QUIT Y
+17 ;
SELELDET(DFLT) ; Select ARCH Eligibility Determination
+1 ; Input Variable -> DFLT = 0 - CAC
+2 ; 1 - SAS DB Update
+3 ; 2 - All
+4 ;
+5 ; Return Value -> New Person File IEN of CAC
+6 ; -1 - SAS DB Update
+7 ; 0 - All
+8 ; ^ - EXIT
+9 ;
+10 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+11 SET DFLT=$SELECT($GET(DFLT)=0:"U",$GET(DFLT)=1:"N",1:"A")
+12 SET DIR(0)="S^C:Project ARCH CAC;S:SAS DB Update;A:All"
SET DIR("A")="Select ARCH Elig Determination (C)AC, (S)AS DB update or (A)LL"
SET DIR("B")=DFLT
+13 DO ^DIR
+14 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)
SET Y="^"
+15 SET Y=$SELECT(Y="C":1,Y="S":0,Y="A":-1,1:Y)
+16 IF Y=1
Begin DoDot:1
+17 NEW DIR,DIRUT,DTOUT,DUOUT
+18 ;Prompt to select NEW PERSON file entry. Screen on ELIGIBILITY SOURCE
+19 SET DIR(0)="P^200:EMZ"
SET DIR("S")="I $D(^FBAAA(""ARCHSRC"",Y))"
+20 SET DIR("A")="Select Project ARCH CAC"
+21 DO ^DIR
IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)
SET Y="^"
+22 SET Y=+Y
End DoDot:1
+23 QUIT Y
+24 ;
SELJUST() ; Select the ARCH Justification Reason
+1 ; Return Value -> FEE BASIS PROJECT ARCH JUSTIFICATION file #161.35 IEN
+2 ;
+3 NEW FBJUST,IEN,X,CNT,FBJAR,DIR,DTOUT,DUOUT,Y
+4 SET (FBJUST,X,CNT)=0
+5 WRITE !!," Project ARCH Justification Reasons",!
+6 FOR
SET FBJUST=$ORDER(^FBAA(161.35,"C",FBJUST))
if FBJUST=""
QUIT
Begin DoDot:1
+7 SET IEN=$ORDER(^FBAA(161.35,"C",FBJUST,0))
+8 if $PIECE(^FBAA(161.35,IEN,0),U,2)'=1
QUIT
+9 SET CNT=CNT+1
+10 SET FBJAR(CNT)=FBJUST_U_IEN
End DoDot:1
+11 FOR
SET X=$ORDER(FBJAR(X))
if X=""
QUIT
Begin DoDot:1
+12 WRITE !,?5,X
+13 IF $LENGTH($PIECE(FBJAR(X),U))>69
Begin DoDot:2
+14 ; Handle the line breaks and hyphenate the word in the right spot
+15 IF $EXTRACT($PIECE(FBJAR(X),U),70)'=" "
Begin DoDot:3
+16 WRITE ?10,$EXTRACT($PIECE(FBJAR(X),U),1,69),"-"
+17 WRITE !,?10,$EXTRACT($PIECE(FBJAR(X),U),70,$LENGTH($PIECE(FBJAR(X),U)))
End DoDot:3
QUIT
+18 WRITE ?10,$EXTRACT($PIECE(FBJAR(X),U),1,70)
+19 WRITE !,?10,$EXTRACT($PIECE(FBJAR(X),U),71,$LENGTH($PIECE(FBJAR(X),U)))
End DoDot:2
End DoDot:1
+20 WRITE !
+21 SET DIR(0)="N^1:"_CNT
SET DIR("A")="Select ARCH Justification"
DO ^DIR
+22 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)
SET Y="^"
QUIT Y
+23 WRITE " ",$PIECE(FBJAR(Y),U),!
+24 QUIT $PIECE(FBJAR(Y),U,2)
+25 ;
HEXC ; - 'Do you want to capture data...' prompt
+1 WRITE !!," Enter: 'Y' - To capture detail report data to transfer"
+2 WRITE !," to an Excel document"
+3 WRITE !," '<CR>' - To skip this option"
+4 WRITE !," '^' - To quit this option"
+5 QUIT
+6 ;
+7 ;Display the message about capturing to an Excel file format
+8 ;
EXMSG ;
+1 WRITE !!?5,"Before continuing, please set up your terminal to capture the"
+2 WRITE !?5,"detail report data. On some terminals, this can be done by"
+3 WRITE !?5,"clicking on the 'Tools' menu above, then click on 'Capture"
+4 WRITE !?5,"Incoming Data' to save to Desktop. This report may take a"
+5 WRITE !?5,"while to run."
+6 WRITE !!?5,"Note: To avoid undesired wrapping of the data saved to the"
+7 WRITE !?5," file, please enter '0;256;999' at the 'DEVICE:' prompt.",!
+8 QUIT
+9 ;
+10 ;Screen Pause 1
+11 ;
+12 ; Return variable - FBQ = 0 Continue
+13 ; 2 Quit
PAUSE NEW X
+1 USE IO(0)
WRITE !!,"Press RETURN to continue, '^' to exit:"
+2 READ X:$GET(DTIME)
if '$TEST
SET X="^"
if X["^"
SET FBQ=2
+3 USE IO
+4 QUIT
+5 ;
+6 ;Screen Pause 2
+7 ;
+8 ; Return variable - FBQ = 0 Continue
+9 ; 2 Quit
PAUSE2 NEW X
+1 USE IO(0)
WRITE !!,"Press RETURN to continue:"
+2 READ X:$GET(DTIME)
if '$TEST
SET X="^"
if X["^"
SET FBQ=2
+3 USE IO
+4 QUIT
+5 ;
CHKKEY(KEY) ; Check if user holds the appropriate security key
+1 ; Return 1 if user holds key, 0 if not and display message
+2 if KEY']""
QUIT 0
+3 IF $DATA(^XUSEC(KEY,DUZ))
QUIT 1
+4 WRITE !,"You must hold the "_KEY_" Security Key in order to continue."
+5 DO PAUSE2
+6 QUIT 0
+7 ;
REPORT(REF,FBEXCEL,FBSCR,FBRPTNAM,FBPAT,FBBEGDT,FBENDDT,FBELIG,FBELDET,FBSUMDET,FBPAGE) ; Display the report
+1 NEW DFN,ELIGDT,DETUSR,FB11,ELIGIND,FBARCH0,FBCNT
+2 NEW NP,FBLOCNT,FBNCNT,FBNELCNT,FBNPAT,FBELPAT
+3 SET (FBLOCNT,FBNCNT,FBNELCNT,FBCNT)=0
+4 DO HDR(FBRPTNAM,.FBPAGE)
+5 IF '$DATA(@REF)
WRITE !,"No data meets the criteria."
GOTO XREPORT
+6 ;
+7 SET DFN=""
FOR
SET DFN=$ORDER(@REF@(DFN))
if DFN=""
QUIT
Begin DoDot:1
+8 if '$DATA(^DPT(DFN))
QUIT
+9 ; Check the patient filter
+10 IF FBPAT
if DFN'=FBPAT
QUIT
+11 SET FBNPAT=1
+12 SET ELIGDT=""
FOR
SET ELIGDT=$ORDER(@REF@(DFN,ELIGDT))
if ELIGDT=""
QUIT
Begin DoDot:2
+13 ; Check the date filters
+14 IF FBBEGDT
IF ELIGDT<FBBEGDT
QUIT
+15 SET FB11=""
FOR
SET FB11=$ORDER(@REF@(DFN,ELIGDT,FB11))
if FB11=""
QUIT
Begin DoDot:3
+16 SET FBARCH0=^FBAAA(DFN,"ARCHFEE",FB11,0)
+17 SET ELIGIND=$PIECE(FBARCH0,U,2)
+18 SET DETUSR=$SELECT($PIECE(FBARCH0,U,3)]"":$PIECE(^VA(200,$PIECE(FBARCH0,U,3),0),U),1:"SAS DB UPDATE")
+19 ; Check the Eligibility filter
+20 IF FBELIG'=2
IF FBELIG'=ELIGIND
QUIT
+21 ; Check Determination Source filter
+22 IF FBELDET>0
IF FBELDET'=$PIECE(FBARCH0,U,3)
QUIT
+23 IF FBELDET=0
IF $PIECE(FBARCH0,U,3)]""
QUIT
+24 ; Set eligibility counter
+25 SET FBELPAT(DFN)=$SELECT((ELIGIND)&($PIECE(FBARCH0,U,3)]""):1,(ELIGIND)&($PIECE(FBARCH0,U,3)=""):2,1:0)
+26 IF FBNPAT
SET FBCNT=FBCNT+1
+27 SET NP=$$CHKP(1)
if FBQ
QUIT
+28 IF 'FBSUMDET
Begin DoDot:4
+29 DO WRLINE1(FBEXCEL,$SELECT(FBNPAT:FBCNT,1:""),$PIECE(^DPT(DFN,0),U),ELIGDT,ELIGIND,DETUSR)
+30 IF $PIECE(FBARCH0,U,4)]""
DO WRLINE2(FBEXCEL,$PIECE(FBARCH0,U,4))
+31 IF $PIECE(FBARCH0,U,5)]""
DO WRLINE3(FBEXCEL,$PIECE(FBARCH0,U,5))
End DoDot:4
+32 ; Reset FBNPAT to not print the ID if same patient
+33 SET FBNPAT=0
End DoDot:3
if FBQ
QUIT
End DoDot:2
if FBQ
QUIT
End DoDot:1
if FBQ
QUIT
+34 if FBQ
QUIT
+35 ; Get the total eligible patients
+36 NEW DFN
SET DFN=""
FOR
SET DFN=$ORDER(FBELPAT(DFN))
if DFN=""
QUIT
Begin DoDot:1
+37 ; Get locally defined eligible patients
+38 IF FBELPAT(DFN)=1
SET FBLOCNT=FBLOCNT+1
QUIT
+39 ; Get nationally defined eligible patients
+40 IF FBELPAT(DFN)=2
SET FBNCNT=FBNCNT+1
QUIT
+41 ; Get locally defined patients changed to Not Eligible
+42 SET FBNELCNT=FBNELCNT+1
End DoDot:1
+43 WRITE !
+44 IF (FBELIG=1)!(FBELIG=2)
WRITE !,"Total Nationally Determined Project ARCH Eligible Patients: "_FBNCNT
+45 IF (FBELIG=1)!(FBELIG=2)
WRITE !,"Total Locally Determined Project ARCH Eligible Patients: "_FBLOCNT
+46 IF (FBELIG=0)!(FBELIG=2)
WRITE !,"Total Locally Determined Eligible changed to Not Eligible: "_FBNELCNT
+47 QUIT
+48 ;
WRLINE1(FBEXCEL,ID,PATIENT,ELIGDT,ELIGIND,DETERM) ; Write Line 1 of report
+1 IF FBEXCEL
WRITE !,ID_U_PATIENT_U_$$FMTE^XLFDT(ELIGDT)_U_$SELECT(ELIGIND=1:"YES",1:"NO")_U_DETERM
QUIT
+2 ;
+3 WRITE !,ID,?8,PATIENT,?35,$$FMTE^XLFDT(ELIGDT),?51,$SELECT(ELIGIND=1:"YES",1:"NO"),?64,DETERM
+4 QUIT
+5 ;
WRLINE2(FBEXCEL,FBJUST) ; Write Line 2 of report
+1 IF FBEXCEL
WRITE U_$PIECE(^FBAA(161.35,FBJUST,0),U)
QUIT
+2 ;
+3 WRITE !,?10,$PIECE(^FBAA(161.35,FBJUST,0),U)
+4 QUIT
+5 ;
WRLINE3(FBEXCEL,FBMILE) ; Write Line 3 of report
+1 IF FBEXCEL
WRITE U_FBMILE
QUIT
+2 ;
+3 WRITE !,?12,FBMILE
+4 QUIT
+5 ;
+6 ;Check for End of Page
+7 ; Input variables -> FBLINES -> Number of lines from bottom
+8 ; FBEXCEL -> 1 - Print to Excel/0 Regular Display
+9 ; Output variable -> FBDATA -> 0 -> New screen, no data displayed yet
+10 ; 1 -> Data displayed on current screen
CHKP(FBLINES) if $GET(FBEXCEL)
QUIT 0
+1 SET FBLINES=FBLINES+1
+2 IF $GET(FBSCR)
SET FBLINES=FBLINES+2
+3 IF $GET(FBSCR)
IF '$GET(FBDATA)
SET FBDATA=1
QUIT 0
+4 SET FBDATA=1
+5 IF $Y>(IOSL-FBLINES)
if $GET(FBSCR)
DO PAUSE
if $GET(FBQ)
QUIT 0
DO HDR(FBRPTNAM,.FBPAGE)
QUIT 1
+6 QUIT 0
+7 ;
+8 ;Print one line of characters
ULINE(X) NEW I
+1 WRITE !
FOR I=1:1:80
WRITE $GET(X,"-")
+2 QUIT
+3 ;
HDR(FBRPTNAM,FBPAGE) ;
+1 ;Display Excel Header
+2 IF FBEXCEL
DO EXHDR
QUIT
+3 ;
+4 ; Define FBDATA - Tells whether data has been displayed for a screen
+5 SET FBDATA=0
+6 SET FBPAGE=$GET(FBPAGE)+1
+7 WRITE @IOF
+8 WRITE FBRPTNAM_" ("_$SELECT(FBSUMDET=1:"SUMMARY",1:"DETAIL")_" REPORT)"
+9 WRITE $$RJ("Page: "_FBPAGE,30)
+10 WRITE !,"Print Date: "_$GET(FBNOW)
+11 IF +FBBEGDT
WRITE !,"Report Date From "_$$DATTIM(FBBEGDT)_" through "_$$DATTIM($PIECE(FBENDDT,"."))
+12 ;
+13 ;
+14 DO ULINE("-")
if $GET(FBQ)
QUIT
+15 ; If just printing Summary, no need to print other headers
+16 IF FBSUMDET
QUIT
+17 DO HEADLN1
+18 DO HEADLN2
+19 DO HEADLN3
+20 DO ULINE("-")
+21 ;
+22 QUIT
+23 ;
EXHDR ; Write the Excel Report Header
+1 WRITE !,"ID#"_U
+2 WRITE "PATIENT"_U
+3 WRITE "ELIG DATE"_U
+4 WRITE "ELIGIBLE"_U
+5 WRITE "DETERMINATION"_U
+6 WRITE "LOCAL JUSTIFICATION"_U
+7 WRITE "LOCAL VERIFICATION OF MILEAGE"_U
+8 QUIT
+9 ;
DATTIM(X) ;Convert FM date or date.time to displayable (mm/dd/yy HH:MM) format
+1 NEW DATE,FBT,FBM,FBH,FBAP
+2 SET DATE=$SELECT(X:$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3),1:"")
+3 SET FBT=$PIECE(X,".",2)
if $LENGTH(FBT)<4
SET FBT=FBT_$EXTRACT("0000",1,4-$LENGTH(FBT))
+4 SET FBH=$EXTRACT(FBT,1,2)
SET FBM=$EXTRACT(FBT,3,4)
+5 SET FBAP="AM"
IF FBH>12
SET FBH=FBH-12
SET FBAP="PM"
if $LENGTH(FBH)<2
SET FBH="0"_FBH
+6 IF FBT
if 'FBH
SET FBH=12
SET DATE=DATE_" "_FBH_":"_FBM_FBAP
+7 QUIT $GET(DATE)
+8 ;
HEADLN1 ; Write the first header line
+1 WRITE !,"ID#",?8,"Patient",?35,"Elig Date",?51,"Eligible",?64,"Determination"
+2 QUIT
+3 ;
HEADLN2 ; Write the second header line
+1 WRITE !,?10,"Local Project ARCH Justification"
+2 QUIT
+3 ;
HEADLN3 ; Write the third header line
+1 WRITE !,?12,"Local Verification of Mileage"
+2 QUIT
+3 ;
XREPORT QUIT
+1 ;
+2 ;left justified, blank padded
+3 ;adds spaces on right or truncates to make return string FBLEN characters long
+4 ;FBST- original string
+5 ;FBLEN - desired length
LJ(FBST,FBLEN) ;
+1 NEW FBL
+2 SET FBL=FBLEN-$LENGTH(FBST)
+3 QUIT $EXTRACT(FBST_$JUSTIFY("",$SELECT(FBL<0:0,1:FBL)),1,FBLEN)
+4 ;
+5 ;right justified, blank padded
+6 ;adds spaces on left or truncates to make return string FBLEN characters long
+7 ;FBST- original string
+8 ;FBLEN - desired length
RJ(FBST,FBLEN) ;
+1 SET FBL=FBLEN-$LENGTH(FBST)
+2 IF FBL>0
QUIT $JUSTIFY("",$SELECT(FBL<0:0,1:FBL))_FBST
+3 QUIT $EXTRACT(FBST,1,FBLEN)
