FBARCH0.m

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 ---FBARCH0   5674     printed  Feb 18, 2025@23:23:44                                                                                                                                                                                                     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       ;