FBARCH0 ; HINOIFO/RVD - ARCH IMPORT ELIGIBILITY AND UTILITY ; 01/08/11 12:30pm
;;3.5;FEE BASIS;**119,130,138**;JAN 30, 1995;Build 3
;;Per VHA Directive 2004-038, this routine should not be modified.
;Integration Agreements:
; ^DPT( - #2070, 10035
; ^DIE - #2053
; ^VASITE -#10112
; ^XUAF4 - #2171
; ^DIC(4 - #10090
; ^MPIF001 - #2701
; @XPDGREF - 2433
; DT^DILF - #2054
Q
;
EN ; entry point
;
N CNT,DFN,DIR,DTOUT,DUOUT,DIRUT,DIROUT,FBDATA,FBDATE,FBDIR,FBFILE,FBTOT,FBX,FBY,X,Y,Z
K ^TMP("FBARCH",$J)
S FBDIR=$$PWD^%ZISH
;
S DIR("A")="Enter host file directory",DIR("B")=FBDIR
S DIR("?",1)="Enter the full path specification where the host file may be found"
S DIR("?")="or press return for the default directory "_FBDIR
S DIR(0)="FO^3:60"
D ^DIR K DIR
S FBDIR=$S($D(DUOUT)!$D(DTOUT):-1,1:Y)
I FBDIR=-1!(FBDIR="") G STARTX
;
S DIR("A")="Enter host file name"
S DIR("?")="Enter the name of the host file to upload"
S DIR(0)="FO^3:60"
D ^DIR K DIR
S FBFILE=$S($D(DUOUT)!$D(DTOUT):-1,1:Y)
I FBFILE=-1!(FBFILE="") G STARTX
S FBX(FBFILE)="",Z=$$LIST^%ZISH(FBDIR,"FBX","FBY") K FBX,FBY
I 'Z D G STARTX
.W !!,"File "_FBFILE_" not found in directory "_FBDIR
.S DIR(0)="E" D ^DIR
.Q
; load data into global ^TMP("FBARCH",$J,n)
W !!,"Loading data into temporary global..."
S Z=$$FTG^%ZISH(FBDIR,FBFILE,$NA(^TMP("FBARCH",$J,1)),3)
I 'Z D G STARTX
.W !!,"Unable to load data from file "_FBDIR_FBFILE
.S DIR(0)="E" D ^DIR
.Q
S FBTOT=$O(^TMP("FBARCH",$J,""),-1) ; total number of records in the file
I 'FBTOT W "No records found." S DIR(0)="E" D ^DIR G STARTX
W "Done."
W !!,FBTOT," records found",!
S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you wish to continue uploading ARCH eligibility data from this file"
D ^DIR K DIR
I Y'>0 G STARTX
; process records
W !!,"Processing records..."
S CNT=0,Z="" F S Z=$O(^TMP("FBARCH",$J,Z)) Q:'Z D
.S FBDATA=$G(^TMP("FBARCH",$J,Z))
.; get and validate DFN
.S DFN=+$$GETDFN^MPIF001($P(FBDATA,U)) I DFN'>0 Q
.; get and validate date
.D DT^DILF("E",$P(FBDATA,U,2),.FBDATE) I FBDATE'>0 Q
.S CNT=CNT+1 I CNT#10=0 W "."
.; process record
.D SETREC(DFN,FBDATE)
.Q
W "Done"
W !!,CNT," records processed."
W !,"Upload complete",!
S DIR(0)="E" D ^DIR
STARTX ;
K ^TMP("FBARCH",$J)
Q
;
SETREC(DFN,FBDATE) ; create/update entry in file 161
; DFN - ien in file 2/file 161
; FBDATE - ARCH eligibility date
N DA,DIC,DINUM,DLAYGO,IEN,X,Y
; add this patient to file 161 if there's no existing entry
S IEN=$O(^FBAAA("B",DFN,""))
I 'IEN K DO S (X,DINUM,DA)=DFN,DIC="^FBAAA(",DIC(0)="LM",DLAYGO=161 D FILE^DICN S IEN=+Y K DINUM
; update ARCH eligibility
I $O(^FBAAA("ARCH",FBDATE,DFN,""))>0 Q ; ARCH eligibility record already exists
K DA,DO
S X=FBDATE,DA(1)=IEN,DLAYGO=161.011,DIC="^FBAAA("_IEN_",""ARCHFEE"",",DIC(0)="LM",DIC("DR")="2////1"
D FILE^DICN
Q
;
ELIG(DFN,FBBDT,FBEDT,FBDATA) ;this function returns if pt is ARCH eligible or NOT
; input: = DFN - patient IEN (pointer to file #161)
; FBBDT - beginning dt
; FBEDT - ending dt
; output: FBDATA = 1 if eligible and FBDATA()=DFN^0 or 1^date of eligibility
; from most recent to the oldest
; FBDATA = 0 if not eligible
;
N FBI,FBDAT,FBEL,FBHDT,FBCNT,FBELDT,FBSAV1,FBSAV2,FBJ
S (FBHDT,FBEL,FBELDT,FBCNT,FBDATA)=0
S FBBDT=$S(FBBDT>0:FBBDT,1:0)
S FBEDT=$S(FBEDT>0:FBEDT,1:9999999)
Q:(FBEDT<FBBDT) FBDATA
Q:'$D(^FBAAA(DFN,"ARCHFEE")) FBDATA
S FBI=$O(^FBAAA(DFN,"ARCHFEE","B"," "),-1)
S FBJ=$O(^FBAAA(DFN,"ARCHFEE","B",FBI," "),-1),FBDAT=$G(^FBAAA(DFN,"ARCHFEE",FBJ,0))
I (FBEDT=FBI)!(FBEDT>FBI) D
.S FBEL=$P(FBDAT,U,2)
.S FBCNT=FBCNT+1 S FBDATA(FBCNT)=FBEL_U_FBI,FBDATA=FBEL
F S FBI=$O(^FBAAA(DFN,"ARCHFEE","B",FBI),-1) Q:FBI'>0 D
.S FBJ=$O(^FBAAA(DFN,"ARCHFEE","B",FBI,0)),FBDAT=$G(^FBAAA(DFN,"ARCHFEE",FBJ,0))
.Q:(FBEDT<FBI)
.S FBEL=$P(FBDAT,U,2),FBCNT=FBCNT+1
.S FBDATA(FBCNT)=FBEL_U_FBI
;
S:$G(FBDATA(1)) FBDATA=$P(FBDATA(1),U)
Q FBDATA
;
LIST(FBBDT,FBEDT) ;this function returns a list of ARCH patients w/in the date range.
; input: = FBBGT - beginning dt
; FBEDT - ending dt
; output:= number of ARCH eligible pt and ^TMP($J,"ARCHFEE",#)=DFN^0 or 1^date of eligibility
; from the OLDEST to the MOST RECENT
; FBJ - internal entry number of file #161 which is DINUM to Patient File (2)
N FBCOUNT,FBI,FBJ,FBEDAT,FBHDAT,FBELDA,FBELDT,FBEL,FBHDT,FBH,FBDFI
K ^TMP($J,"ARCHFEE") S (FBI,FBCOUNT,FBELDT)=0
Q:'$D(^FBAAA("ARCH")) FBCOUNT
S FBBDT=$S(FBBDT>0:FBBDT,1:0)
S FBEDT=$S(FBEDT>0:FBEDT,1:9999999)
Q:(FBEDT<FBBDT) FBCOUNT
F S FBI=$O(^FBAAA("ARCH",FBI)) Q:FBI="" D
.F FBJ=0:0 S FBJ=$O(^FBAAA("ARCH",FBI,FBJ)) Q:FBJ'>0 D
..S FBDFI=$O(^FBAAA("ARCH",FBI,FBJ,0))
..S FBEDAT=$G(^FBAAA(FBJ,"ARCHFEE",FBDFI,0)),FBELDT=$P(FBEDAT,U)
..Q:(FBEDT<FBELDT)
..S FBCOUNT=FBCOUNT+1
..S ^TMP($J,"ARCHFEE",FBCOUNT)=FBJ_U_$P(FBEDAT,U,2)_U_FBELDT
Q FBCOUNT
;
PARSE(FB) ; parse - remove double quotes and trailing blanks if any
N I,B
Q:FB="" FB
S:$E(FB,1)="""" FB=$E(FB,2,$L(FB))
S:$E(FB,$L(FB))="""" FB=$E(FB,1,($L(FB)-1))
Q:$E(FB,$L(FB))'=" " FB ; Last char is non-blank
F I=$L(FB):-1:1 Q:$E(FB,I)'=" " S B=$E(FB,1,I-1)
S FB=B
Q FB
;
GETDELAY() ; return the Project ARCH Reminder Delay - default is 1.
N FBDELAY
S FBDELAY=$P($G(^FBAA(161.4,1,"ARCH")),U)
Q $S(FBDELAY]"":FBDELAY,1:1)
;
SETDELAY ; Edit the Fee Basis Site Parameters for the Project ARCH Reminder Delay
N DIE,DIC,DA,DR,FBPOP
D SITEP^FBAAUTL Q:FBPOP
W !! S DIE="^FBAA(161.4,",DIC(0)="AELQ",DA=1,DR="38//1" D ^DIE
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBARCH0 5674 printed Sep 23, 2025@19:33:23 Page 2
FBARCH0 ; HINOIFO/RVD - ARCH IMPORT ELIGIBILITY AND UTILITY ; 01/08/11 12:30pm
+1 ;;3.5;FEE BASIS;**119,130,138**;JAN 30, 1995;Build 3
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;Integration Agreements:
+4 ; ^DPT( - #2070, 10035
+5 ; ^DIE - #2053
+6 ; ^VASITE -#10112
+7 ; ^XUAF4 - #2171
+8 ; ^DIC(4 - #10090
+9 ; ^MPIF001 - #2701
+10 ; @XPDGREF - 2433
+11 ; DT^DILF - #2054
+12 QUIT
+13 ;
EN ; entry point
+1 ;
+2 NEW CNT,DFN,DIR,DTOUT,DUOUT,DIRUT,DIROUT,FBDATA,FBDATE,FBDIR,FBFILE,FBTOT,FBX,FBY,X,Y,Z
+3 KILL ^TMP("FBARCH",$JOB)
+4 SET FBDIR=$$PWD^%ZISH
+5 ;
+6 SET DIR("A")="Enter host file directory"
SET DIR("B")=FBDIR
+7 SET DIR("?",1)="Enter the full path specification where the host file may be found"
+8 SET DIR("?")="or press return for the default directory "_FBDIR
+9 SET DIR(0)="FO^3:60"
+10 DO ^DIR
KILL DIR
+11 SET FBDIR=$SELECT($DATA(DUOUT)!$DATA(DTOUT):-1,1:Y)
+12 IF FBDIR=-1!(FBDIR="")
GOTO STARTX
+13 ;
+14 SET DIR("A")="Enter host file name"
+15 SET DIR("?")="Enter the name of the host file to upload"
+16 SET DIR(0)="FO^3:60"
+17 DO ^DIR
KILL DIR
+18 SET FBFILE=$SELECT($DATA(DUOUT)!$DATA(DTOUT):-1,1:Y)
+19 IF FBFILE=-1!(FBFILE="")
GOTO STARTX
+20 SET FBX(FBFILE)=""
SET Z=$$LIST^%ZISH(FBDIR,"FBX","FBY")
KILL FBX,FBY
+21 IF 'Z
Begin DoDot:1
+22 WRITE !!,"File "_FBFILE_" not found in directory "_FBDIR
+23 SET DIR(0)="E"
DO ^DIR
+24 QUIT
End DoDot:1
GOTO STARTX
+25 ; load data into global ^TMP("FBARCH",$J,n)
+26 WRITE !!,"Loading data into temporary global..."
+27 SET Z=$$FTG^%ZISH(FBDIR,FBFILE,$NAME(^TMP("FBARCH",$JOB,1)),3)
+28 IF 'Z
Begin DoDot:1
+29 WRITE !!,"Unable to load data from file "_FBDIR_FBFILE
+30 SET DIR(0)="E"
DO ^DIR
+31 QUIT
End DoDot:1
GOTO STARTX
+32 ; total number of records in the file
SET FBTOT=$ORDER(^TMP("FBARCH",$JOB,""),-1)
+33 IF 'FBTOT
WRITE "No records found."
SET DIR(0)="E"
DO ^DIR
GOTO STARTX
+34 WRITE "Done."
+35 WRITE !!,FBTOT," records found",!
+36 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Do you wish to continue uploading ARCH eligibility data from this file"
+37 DO ^DIR
KILL DIR
+38 IF Y'>0
GOTO STARTX
+39 ; process records
+40 WRITE !!,"Processing records..."
+41 SET CNT=0
SET Z=""
FOR
SET Z=$ORDER(^TMP("FBARCH",$JOB,Z))
if 'Z
QUIT
Begin DoDot:1
+42 SET FBDATA=$GET(^TMP("FBARCH",$JOB,Z))
+43 ; get and validate DFN
+44 SET DFN=+$$GETDFN^MPIF001($PIECE(FBDATA,U))
IF DFN'>0
QUIT
+45 ; get and validate date
+46 DO DT^DILF("E",$PIECE(FBDATA,U,2),.FBDATE)
IF FBDATE'>0
QUIT
+47 SET CNT=CNT+1
IF CNT#10=0
WRITE "."
+48 ; process record
+49 DO SETREC(DFN,FBDATE)
+50 QUIT
End DoDot:1
+51 WRITE "Done"
+52 WRITE !!,CNT," records processed."
+53 WRITE !,"Upload complete",!
+54 SET DIR(0)="E"
DO ^DIR
STARTX ;
+1 KILL ^TMP("FBARCH",$JOB)
+2 QUIT
+3 ;
SETREC(DFN,FBDATE) ; create/update entry in file 161
+1 ; DFN - ien in file 2/file 161
+2 ; FBDATE - ARCH eligibility date
+3 NEW DA,DIC,DINUM,DLAYGO,IEN,X,Y
+4 ; add this patient to file 161 if there's no existing entry
+5 SET IEN=$ORDER(^FBAAA("B",DFN,""))
+6 IF 'IEN
KILL DO
SET (X,DINUM,DA)=DFN
SET DIC="^FBAAA("
SET DIC(0)="LM"
SET DLAYGO=161
DO FILE^DICN
SET IEN=+Y
KILL DINUM
+7 ; update ARCH eligibility
+8 ; ARCH eligibility record already exists
IF $ORDER(^FBAAA("ARCH",FBDATE,DFN,""))>0
QUIT
+9 KILL DA,DO
+10 SET X=FBDATE
SET DA(1)=IEN
SET DLAYGO=161.011
SET DIC="^FBAAA("_IEN_",""ARCHFEE"","
SET DIC(0)="LM"
SET DIC("DR")="2////1"
+11 DO FILE^DICN
+12 QUIT
+13 ;
ELIG(DFN,FBBDT,FBEDT,FBDATA) ;this function returns if pt is ARCH eligible or NOT
+1 ; input: = DFN - patient IEN (pointer to file #161)
+2 ; FBBDT - beginning dt
+3 ; FBEDT - ending dt
+4 ; output: FBDATA = 1 if eligible and FBDATA()=DFN^0 or 1^date of eligibility
+5 ; from most recent to the oldest
+6 ; FBDATA = 0 if not eligible
+7 ;
+8 NEW FBI,FBDAT,FBEL,FBHDT,FBCNT,FBELDT,FBSAV1,FBSAV2,FBJ
+9 SET (FBHDT,FBEL,FBELDT,FBCNT,FBDATA)=0
+10 SET FBBDT=$SELECT(FBBDT>0:FBBDT,1:0)
+11 SET FBEDT=$SELECT(FBEDT>0:FBEDT,1:9999999)
+12 if (FBEDT<FBBDT)
QUIT FBDATA
+13 if '$DATA(^FBAAA(DFN,"ARCHFEE"))
QUIT FBDATA
+14 SET FBI=$ORDER(^FBAAA(DFN,"ARCHFEE","B"," "),-1)
+15 SET FBJ=$ORDER(^FBAAA(DFN,"ARCHFEE","B",FBI," "),-1)
SET FBDAT=$GET(^FBAAA(DFN,"ARCHFEE",FBJ,0))
+16 IF (FBEDT=FBI)!(FBEDT>FBI)
Begin DoDot:1
+17 SET FBEL=$PIECE(FBDAT,U,2)
+18 SET FBCNT=FBCNT+1
SET FBDATA(FBCNT)=FBEL_U_FBI
SET FBDATA=FBEL
End DoDot:1
+19 FOR
SET FBI=$ORDER(^FBAAA(DFN,"ARCHFEE","B",FBI),-1)
if FBI'>0
QUIT
Begin DoDot:1
+20 SET FBJ=$ORDER(^FBAAA(DFN,"ARCHFEE","B",FBI,0))
SET FBDAT=$GET(^FBAAA(DFN,"ARCHFEE",FBJ,0))
+21 if (FBEDT<FBI)
QUIT
+22 SET FBEL=$PIECE(FBDAT,U,2)
SET FBCNT=FBCNT+1
+23 SET FBDATA(FBCNT)=FBEL_U_FBI
End DoDot:1
+24 ;
+25 if $GET(FBDATA(1))
SET FBDATA=$PIECE(FBDATA(1),U)
+26 QUIT FBDATA
+27 ;
LIST(FBBDT,FBEDT) ;this function returns a list of ARCH patients w/in the date range.
+1 ; input: = FBBGT - beginning dt
+2 ; FBEDT - ending dt
+3 ; output:= number of ARCH eligible pt and ^TMP($J,"ARCHFEE",#)=DFN^0 or 1^date of eligibility
+4 ; from the OLDEST to the MOST RECENT
+5 ; FBJ - internal entry number of file #161 which is DINUM to Patient File (2)
+6 NEW FBCOUNT,FBI,FBJ,FBEDAT,FBHDAT,FBELDA,FBELDT,FBEL,FBHDT,FBH,FBDFI
+7 KILL ^TMP($JOB,"ARCHFEE")
SET (FBI,FBCOUNT,FBELDT)=0
+8 if '$DATA(^FBAAA("ARCH"))
QUIT FBCOUNT
+9 SET FBBDT=$SELECT(FBBDT>0:FBBDT,1:0)
+10 SET FBEDT=$SELECT(FBEDT>0:FBEDT,1:9999999)
+11 if (FBEDT<FBBDT)
QUIT FBCOUNT
+12 FOR
SET FBI=$ORDER(^FBAAA("ARCH",FBI))
if FBI=""
QUIT
Begin DoDot:1
+13 FOR FBJ=0:0
SET FBJ=$ORDER(^FBAAA("ARCH",FBI,FBJ))
if FBJ'>0
QUIT
Begin DoDot:2
+14 SET FBDFI=$ORDER(^FBAAA("ARCH",FBI,FBJ,0))
+15 SET FBEDAT=$GET(^FBAAA(FBJ,"ARCHFEE",FBDFI,0))
SET FBELDT=$PIECE(FBEDAT,U)
+16 if (FBEDT<FBELDT)
QUIT
+17 SET FBCOUNT=FBCOUNT+1
+18 SET ^TMP($JOB,"ARCHFEE",FBCOUNT)=FBJ_U_$PIECE(FBEDAT,U,2)_U_FBELDT
End DoDot:2
End DoDot:1
+19 QUIT FBCOUNT
+20 ;
PARSE(FB) ; parse - remove double quotes and trailing blanks if any
+1 NEW I,B
+2 if FB=""
QUIT FB
+3 if $EXTRACT(FB,1)=""""
SET FB=$EXTRACT(FB,2,$LENGTH(FB))
+4 if $EXTRACT(FB,$LENGTH(FB))=""""
SET FB=$EXTRACT(FB,1,($LENGTH(FB)-1))
+5 ; Last char is non-blank
if $EXTRACT(FB,$LENGTH(FB))'=" "
QUIT FB
+6 FOR I=$LENGTH(FB):-1:1
if $EXTRACT(FB,I)'=" "
QUIT
SET B=$EXTRACT(FB,1,I-1)
+7 SET FB=B
+8 QUIT FB
+9 ;
GETDELAY() ; return the Project ARCH Reminder Delay - default is 1.
+1 NEW FBDELAY
+2 SET FBDELAY=$PIECE($GET(^FBAA(161.4,1,"ARCH")),U)
+3 QUIT $SELECT(FBDELAY]"":FBDELAY,1:1)
+4 ;
SETDELAY ; Edit the Fee Basis Site Parameters for the Project ARCH Reminder Delay
+1 NEW DIE,DIC,DA,DR,FBPOP
+2 DO SITEP^FBAAUTL
if FBPOP
QUIT
+3 WRITE !!
SET DIE="^FBAA(161.4,"
SET DIC(0)="AELQ"
SET DA=1
SET DR="38//1"
DO ^DIE
+4 QUIT
+5 ;
