FBARCHU ; HINOIFO/BNT - ARCH ELIGIBILITY ; 05/03/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
;
ADD ; Add patient to the ARCH ELIGIBILITY Multiple
N FBQUIT,Y,X,DFN,DA,FBARCH,FBUSER,FBJUST,FBMILE,FBDATA,FBI11,FBIEN2,FBSITE,FBPOP,DUOUT,DTOUT,DIRUT,DIROUT,DINUM,DLAYGO,DILOCKTM,DD,DO,D,DIC,DIR
S (FBARCH,FBQUIT)=0,(FBJUST,FBMILE)=""
D SITEP^FBAAUTL Q:FBPOP ;S FBAADDYS=+$P(FBSITE(0),"^",13),FBAAASKV=$P(FBSITE(1),"^",1),FBPROG=$S($P(FBSITE(1),"^",6)="":"I 1",1:"I $P(^(0),U,3)=2")
W ! K DIC S DIC="^DPT(",DIC(0)="QEAZM" D ^DIC S DFN=+Y
Q:'$D(^DPT(DFN))
S DA=DFN I '$D(^FBAAA(DA,0)) D Q:FBQUIT
. L +^FBAAA(DFN):$G(DILOCKTM,3) I '$T D S FBQUIT=1 Q
. . W !,"This record is being edited by another user. Try again later.",!
. K DD,DO S (X,DINUM)=DA,DIC="^FBAAA(",DIC(0)="LM",DLAYGO=161 D FILE^DICN L -^FBAAA(DFN) K DIC
S:'$D(^FBAAA(DFN,1,0)) ^(0)="^161.01D^^"
I $D(^FBAAA(DFN,"ARCHFEE")) D Q:FBQUIT
. S FBI11=$O(^FBAAA(DFN,"ARCHFEE"," "),-1)
. S FBARCH=$P(^FBAAA(DFN,"ARCHFEE",FBI11,0),U,2)
. I $P(^FBAAA(DFN,"ARCHFEE",FBI11,0),U,3)="" D Q
. . W !,"This patient was determined Project ARCH Eligible by the"
. . W !,"national extract and cannot be edited."
. . W !!,"Only manually added patients can be edited."
. . S FBQUIT=1 Q
W !,$P(^DPT(DFN,0),U)_" is "_$S(FBARCH>0:"",1:"NOT ")_"Project ARCH eligible.",!
S DIR("A")="Change to "_$S(FBARCH>0:"NOT ",1:"")_"Project ARCH eligible? (Y/N): "
S DIR(0)="YA",DIR("B")="YES" D ^DIR
I $G(DUOUT)!$G(DTOUT)!$G(DIROUT)!$G(DIRUT)!(Y="^") Q
Q:'Y
;
; Prompt for Justification
I 'FBARCH S FBJUST=$$SELJUST^FBARCHR0() I FBJUST="^" G XDEV
;
; Prompt for Verification of Mileage
I 'FBARCH D Q:FBQUIT
. K DIR S DIR(0)="F^3:100:EMZ",DIR("A")="Enter Verification of Mileage"
. S DIR("?")="Enter how the mileage requirement was verified (i.e. Google Maps, Zip Code listing, etc.)"
. D ^DIR
. I $G(DUOUT)!$G(DTOUT)!$G(DIROUT)!$G(DIRUT)!(Y="^") S FBQUIT=1 Q
. S FBMILE=Y K DIR
;
;update eligibility
S FBARCH=$S('FBARCH:1,1:0)
S FBIEN2="+2,"_DFN
S FBDATA(161.011,FBIEN2_",",.01)=$$DT^XLFDT()
S FBDATA(161.011,FBIEN2_",",2)=FBARCH
S FBDATA(161.011,FBIEN2_",",3)=DUZ
I FBJUST]"" S FBDATA(161.011,FBIEN2_",",4)=FBJUST
I FBMILE]"" S FBDATA(161.011,FBIEN2_",",5)=FBMILE
;
D UPDATE^DIE("","FBDATA")
K FBDATA
W !!,$P(^DPT(DFN,0),U)_" is "_$S('FBARCH:"NOT ",1:"")_"Project ARCH eligible.",!
K DIR S DIR(0)="E" D ^DIR
;
Q
;
VIEW ; View Project ARCH Eligibility
N Y,FBNOW,FBSUMDET,FBEXCEL,FBQ,FBRPTNAM,FBPAT,FBBEGDT,FBENDDT,FBELIG,FBELDET,FBDATA,FBSCR
; Quit if the user does not hold the FB ARCH security key
Q:'$$CHKKEY^FBARCHR0("FB ARCH")
;
;Get current Date/Time
D NOW^%DTC S Y=% D DD^%DT S FBNOW=Y
;
S FBRPTNAM="Project ARCH Eligibility Report"
;
;Prompt to Display for One Patient or All Patients (Default to All)
S FBPAT=$$SELPAT^FBARCHR0(0) I FBPAT="^" G XDEV
;
;Prompt to select Eligibility Determination Date Range
;Returns (Start Date^End Date)
S FBBEGDT=$$SELDATE^FBARCHR0(0) D I FBBEGDT="^" G XDEV
. I FBBEGDT="^" Q
. S FBENDDT=$P(FBBEGDT,U,2)
. S FBBEGDT=$P(FBBEGDT,U)
;
;Prompt to select ARCH Eligibility
S FBELIG=$$SELELIG^FBARCHR0(2) I FBELIG="^" G XDEV
;
;Prompt to select ARCH Eligibility Determination
S FBELDET=$$SELELDET^FBARCHR0(2) I FBELDET="^" G XDEV
;
;Prompt to Display Summary or Detail Format (Default to Detail)
;Returns 1 for Summary, 0 for Detail
S FBSUMDET=$$SELSMDET^FBARCHR0(2) I FBSUMDET="^" G XDEV
;
;Prompt for Excel Capture (Detail Only)
S FBEXCEL=0 I 'FBSUMDET S FBEXCEL=$$SELEXCEL^FBARCHR0() I FBEXCEL="^" G XDEV
;
;Prompt for the Device
S FBQ=0 D DEVICE(FBRPTNAM) Q:FBQ
;
;Compile and Run the Report
D RUN(FBEXCEL,FBRPTNAM,FBSUMDET)
I 'FBQ D PAUSE2^FBARCHR0
;
Q
;
RUN(FBEXCEL,FBRPTNAM,FBSUMDET) ; Run the report
N FBPAGE,FBTMP,FBCNT
S FBTMP=$NA(^TMP($J,"ARCH"))
K @FBTMP
S FBPAGE=0
W:FBSCR&'FBEXCEL !,"Please wait...",!
;
;Compile the report
S FBCNT=$$ELIGLST(FBTMP) Q:'FBCNT
U IO
;
;Display the report
D REPORT^FBARCHR0(FBTMP,FBEXCEL,FBSCR,FBRPTNAM,FBPAT,FBBEGDT,FBENDDT,FBELIG,FBELDET,FBSUMDET,FBPAGE)
I 'FBSCR W !,@IOF
;K @FBTMP
I $D(ZTQUEUED) S ZTREQ="@" Q
D ^%ZISC
Q
;
ELIGLST(FBTMP) ; Get the current eligibility list
; Returned in ^TMP($J,"ARCH",DFN,DATE,ELIG IEN)=""
N DFN,FB11,FBDATE,FBCNT
K @FBTMP
S (FBCNT,FBDATE)=0
F S FBDATE=$O(^FBAAA("ARCH",FBDATE)) Q:FBDATE="" D
. S DFN="" F S DFN=$O(^FBAAA("ARCH",FBDATE,DFN)) Q:DFN="" D
. . S FB11="" F S FB11=$O(^FBAAA("ARCH",FBDATE,DFN,FB11)) Q:FB11="" D
. . . S @FBTMP@(DFN,$P(FBDATE,"."),FB11)=""
. . S FBCNT=FBCNT+1
. Q
S @FBTMP@("TOTAL")=FBCNT
Q FBCNT
;
;Prompt For the Device
;
; Returns Device variables and FBSCR
;
DEVICE(FBRPTNAM) ;
N %ZIS,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,POP
S %ZIS="QM"
D ^%ZIS
I POP S FBQ=1
;
;Check for exit
I $G(FBQ) G XDEV
;
S FBSCR=$S($E($G(IOST),1,2)="C-":1,1:0)
I $D(IO("Q")) D S FBQ=1
. S ZTRTN="RUN^FBARCHU(FBEXCEL,FBRPTNAM,FBSUMDET)"
. S ZTIO=ION
. S ZTSAVE("*")=""
. S ZTDESC=FBRPTNAM
. D ^%ZTLOAD
. W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
. D HOME^%ZIS
U IO
XDEV Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBARCHU 5363 printed Sep 23, 2025@19:33:25 Page 2
FBARCHU ; HINOIFO/BNT - ARCH ELIGIBILITY ; 05/03/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 ;
ADD ; Add patient to the ARCH ELIGIBILITY Multiple
+1 NEW FBQUIT,Y,X,DFN,DA,FBARCH,FBUSER,FBJUST,FBMILE,FBDATA,FBI11,FBIEN2,FBSITE,FBPOP,DUOUT,DTOUT,DIRUT,DIROUT,DINUM,DLAYGO,DILOCKTM,DD,DO,D,DIC,DIR
+2 SET (FBARCH,FBQUIT)=0
SET (FBJUST,FBMILE)=""
+3 ;S FBAADDYS=+$P(FBSITE(0),"^",13),FBAAASKV=$P(FBSITE(1),"^",1),FBPROG=$S($P(FBSITE(1),"^",6)="":"I 1",1:"I $P(^(0),U,3)=2")
DO SITEP^FBAAUTL
if FBPOP
QUIT
+4 WRITE !
KILL DIC
SET DIC="^DPT("
SET DIC(0)="QEAZM"
DO ^DIC
SET DFN=+Y
+5 if '$DATA(^DPT(DFN))
QUIT
+6 SET DA=DFN
IF '$DATA(^FBAAA(DA,0))
Begin DoDot:1
+7 LOCK +^FBAAA(DFN):$GET(DILOCKTM,3)
IF '$TEST
Begin DoDot:2
+8 WRITE !,"This record is being edited by another user. Try again later.",!
End DoDot:2
SET FBQUIT=1
QUIT
+9 KILL DD,DO
SET (X,DINUM)=DA
SET DIC="^FBAAA("
SET DIC(0)="LM"
SET DLAYGO=161
DO FILE^DICN
LOCK -^FBAAA(DFN)
KILL DIC
End DoDot:1
if FBQUIT
QUIT
+10 if '$DATA(^FBAAA(DFN,1,0))
SET ^(0)="^161.01D^^"
+11 IF $DATA(^FBAAA(DFN,"ARCHFEE"))
Begin DoDot:1
+12 SET FBI11=$ORDER(^FBAAA(DFN,"ARCHFEE"," "),-1)
+13 SET FBARCH=$PIECE(^FBAAA(DFN,"ARCHFEE",FBI11,0),U,2)
+14 IF $PIECE(^FBAAA(DFN,"ARCHFEE",FBI11,0),U,3)=""
Begin DoDot:2
+15 WRITE !,"This patient was determined Project ARCH Eligible by the"
+16 WRITE !,"national extract and cannot be edited."
+17 WRITE !!,"Only manually added patients can be edited."
+18 SET FBQUIT=1
QUIT
End DoDot:2
QUIT
End DoDot:1
if FBQUIT
QUIT
+19 WRITE !,$PIECE(^DPT(DFN,0),U)_" is "_$SELECT(FBARCH>0:"",1:"NOT ")_"Project ARCH eligible.",!
+20 SET DIR("A")="Change to "_$SELECT(FBARCH>0:"NOT ",1:"")_"Project ARCH eligible? (Y/N): "
+21 SET DIR(0)="YA"
SET DIR("B")="YES"
DO ^DIR
+22 IF $GET(DUOUT)!$GET(DTOUT)!$GET(DIROUT)!$GET(DIRUT)!(Y="^")
QUIT
+23 if 'Y
QUIT
+24 ;
+25 ; Prompt for Justification
+26 IF 'FBARCH
SET FBJUST=$$SELJUST^FBARCHR0()
IF FBJUST="^"
GOTO XDEV
+27 ;
+28 ; Prompt for Verification of Mileage
+29 IF 'FBARCH
Begin DoDot:1
+30 KILL DIR
SET DIR(0)="F^3:100:EMZ"
SET DIR("A")="Enter Verification of Mileage"
+31 SET DIR("?")="Enter how the mileage requirement was verified (i.e. Google Maps, Zip Code listing, etc.)"
+32 DO ^DIR
+33 IF $GET(DUOUT)!$GET(DTOUT)!$GET(DIROUT)!$GET(DIRUT)!(Y="^")
SET FBQUIT=1
QUIT
+34 SET FBMILE=Y
KILL DIR
End DoDot:1
if FBQUIT
QUIT
+35 ;
+36 ;update eligibility
+37 SET FBARCH=$SELECT('FBARCH:1,1:0)
+38 SET FBIEN2="+2,"_DFN
+39 SET FBDATA(161.011,FBIEN2_",",.01)=$$DT^XLFDT()
+40 SET FBDATA(161.011,FBIEN2_",",2)=FBARCH
+41 SET FBDATA(161.011,FBIEN2_",",3)=DUZ
+42 IF FBJUST]""
SET FBDATA(161.011,FBIEN2_",",4)=FBJUST
+43 IF FBMILE]""
SET FBDATA(161.011,FBIEN2_",",5)=FBMILE
+44 ;
+45 DO UPDATE^DIE("","FBDATA")
+46 KILL FBDATA
+47 WRITE !!,$PIECE(^DPT(DFN,0),U)_" is "_$SELECT('FBARCH:"NOT ",1:"")_"Project ARCH eligible.",!
+48 KILL DIR
SET DIR(0)="E"
DO ^DIR
+49 ;
+50 QUIT
+51 ;
VIEW ; View Project ARCH Eligibility
+1 NEW Y,FBNOW,FBSUMDET,FBEXCEL,FBQ,FBRPTNAM,FBPAT,FBBEGDT,FBENDDT,FBELIG,FBELDET,FBDATA,FBSCR
+2 ; Quit if the user does not hold the FB ARCH security key
+3 if '$$CHKKEY^FBARCHR0("FB ARCH")
QUIT
+4 ;
+5 ;Get current Date/Time
+6 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET FBNOW=Y
+7 ;
+8 SET FBRPTNAM="Project ARCH Eligibility Report"
+9 ;
+10 ;Prompt to Display for One Patient or All Patients (Default to All)
+11 SET FBPAT=$$SELPAT^FBARCHR0(0)
IF FBPAT="^"
GOTO XDEV
+12 ;
+13 ;Prompt to select Eligibility Determination Date Range
+14 ;Returns (Start Date^End Date)
+15 SET FBBEGDT=$$SELDATE^FBARCHR0(0)
Begin DoDot:1
+16 IF FBBEGDT="^"
QUIT
+17 SET FBENDDT=$PIECE(FBBEGDT,U,2)
+18 SET FBBEGDT=$PIECE(FBBEGDT,U)
End DoDot:1
IF FBBEGDT="^"
GOTO XDEV
+19 ;
+20 ;Prompt to select ARCH Eligibility
+21 SET FBELIG=$$SELELIG^FBARCHR0(2)
IF FBELIG="^"
GOTO XDEV
+22 ;
+23 ;Prompt to select ARCH Eligibility Determination
+24 SET FBELDET=$$SELELDET^FBARCHR0(2)
IF FBELDET="^"
GOTO XDEV
+25 ;
+26 ;Prompt to Display Summary or Detail Format (Default to Detail)
+27 ;Returns 1 for Summary, 0 for Detail
+28 SET FBSUMDET=$$SELSMDET^FBARCHR0(2)
IF FBSUMDET="^"
GOTO XDEV
+29 ;
+30 ;Prompt for Excel Capture (Detail Only)
+31 SET FBEXCEL=0
IF 'FBSUMDET
SET FBEXCEL=$$SELEXCEL^FBARCHR0()
IF FBEXCEL="^"
GOTO XDEV
+32 ;
+33 ;Prompt for the Device
+34 SET FBQ=0
DO DEVICE(FBRPTNAM)
if FBQ
QUIT
+35 ;
+36 ;Compile and Run the Report
+37 DO RUN(FBEXCEL,FBRPTNAM,FBSUMDET)
+38 IF 'FBQ
DO PAUSE2^FBARCHR0
+39 ;
+40 QUIT
+41 ;
RUN(FBEXCEL,FBRPTNAM,FBSUMDET) ; Run the report
+1 NEW FBPAGE,FBTMP,FBCNT
+2 SET FBTMP=$NAME(^TMP($JOB,"ARCH"))
+3 KILL @FBTMP
+4 SET FBPAGE=0
+5 if FBSCR&'FBEXCEL
WRITE !,"Please wait...",!
+6 ;
+7 ;Compile the report
+8 SET FBCNT=$$ELIGLST(FBTMP)
if 'FBCNT
QUIT
+9 USE IO
+10 ;
+11 ;Display the report
+12 DO REPORT^FBARCHR0(FBTMP,FBEXCEL,FBSCR,FBRPTNAM,FBPAT,FBBEGDT,FBENDDT,FBELIG,FBELDET,FBSUMDET,FBPAGE)
+13 IF 'FBSCR
WRITE !,@IOF
+14 ;K @FBTMP
+15 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+16 DO ^%ZISC
+17 QUIT
+18 ;
ELIGLST(FBTMP) ; Get the current eligibility list
+1 ; Returned in ^TMP($J,"ARCH",DFN,DATE,ELIG IEN)=""
+2 NEW DFN,FB11,FBDATE,FBCNT
+3 KILL @FBTMP
+4 SET (FBCNT,FBDATE)=0
+5 FOR
SET FBDATE=$ORDER(^FBAAA("ARCH",FBDATE))
if FBDATE=""
QUIT
Begin DoDot:1
+6 SET DFN=""
FOR
SET DFN=$ORDER(^FBAAA("ARCH",FBDATE,DFN))
if DFN=""
QUIT
Begin DoDot:2
+7 SET FB11=""
FOR
SET FB11=$ORDER(^FBAAA("ARCH",FBDATE,DFN,FB11))
if FB11=""
QUIT
Begin DoDot:3
+8 SET @FBTMP@(DFN,$PIECE(FBDATE,"."),FB11)=""
End DoDot:3
+9 SET FBCNT=FBCNT+1
End DoDot:2
+10 QUIT
End DoDot:1
+11 SET @FBTMP@("TOTAL")=FBCNT
+12 QUIT FBCNT
+13 ;
+14 ;Prompt For the Device
+15 ;
+16 ; Returns Device variables and FBSCR
+17 ;
DEVICE(FBRPTNAM) ;
+1 NEW %ZIS,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,POP
+2 SET %ZIS="QM"
+3 DO ^%ZIS
+4 IF POP
SET FBQ=1
+5 ;
+6 ;Check for exit
+7 IF $GET(FBQ)
GOTO XDEV
+8 ;
+9 SET FBSCR=$SELECT($EXTRACT($GET(IOST),1,2)="C-":1,1:0)
+10 IF $DATA(IO("Q"))
Begin DoDot:1
+11 SET ZTRTN="RUN^FBARCHU(FBEXCEL,FBRPTNAM,FBSUMDET)"
+12 SET ZTIO=ION
+13 SET ZTSAVE("*")=""
+14 SET ZTDESC=FBRPTNAM
+15 DO ^%ZTLOAD
+16 WRITE !,$SELECT($DATA(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
+17 DO HOME^%ZIS
End DoDot:1
SET FBQ=1
+18 USE IO
XDEV QUIT
