FBUCUTL2 ;ALBISC/TET - UTILITY (CONTINUED) ;2/12/2003
;;3.5;FEE BASIS;**23,32,38,52**;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
ADDRESS(FBUCA) ;set up address (FBADD) and carbon copy address (FBADDCC)
;INPUT: FBUCA = current (or after) zero node for UC (file #162.7)
;OUTPUT: FBADD( array, subscripted by sequential number; FBADD = count
; FBADDCC( array, subscripted by sequential number; FBADDCC=count
N FBDA,FBGL,FBSUB
K FBADD,FBADDCC
S FBSUB=$P(FBUCA,U,23)
S:FBSUB']"" FBSUB=$P(FBUCA,U,4)_";DPT("
S FBDA=+$P(FBSUB,";")
I FBSUB["FBAAV" D VENADD(FBDA,.FBADD) D VETADD($P(FBUCA,U,4),.FBADDCC)
I FBSUB["DPT" D VETADD(FBDA,.FBADD) D VENADD($P(FBUCA,U,3),.FBADDCC)
I FBSUB["VA(200" D OTHADD(FBDA,.FBADD) D VETADD($P(FBUCA,U,4),.FBADDCC)
Q
VETADD(DFN,FBARR) ;set up veteran address
;INPUT: DFN = veteran ien
; FBARR array that will hold the address (passed by reference)
;VAPA("CD") - date for ADD^VADPT if not defined then NOW will be used
; VAPA will be killed!
;
;OUTPUT FBARR array will contain the veteran mailing address,
; subscripted by sequential number; FBARR = line count
N FBCT,FBI
K FBARR
S FBCT=0
I $G(DFN)>0 D
.S FBCT=FBCT+1,FBARR(FBCT)=$$GETNAME^FBUCLET1(DFN,2,"G")
.D ADD^VADPT I 'VAERR D K VAPA,VAERR
. . I $$ACTIVECC^FBAACO0() D Q
. . . F FBI=13,14,15 S:$G(VAPA(FBI))]"" FBCT=FBCT+1,FBARR(FBCT)=$G(VAPA(FBI))
. . . S FBCT=FBCT+1,FBARR(FBCT)=$S($G(VAPA(16))]"":$G(VAPA(16)),1:" ")_" "_$S($P($G(VAPA(17)),U,2)]"":$P($G(VAPA(17)),U,2),1:" ")_" "_$P($G(VAPA(18)),U,2)
..F FBI=1,2,3 S:VAPA(FBI)]"" FBCT=FBCT+1,FBARR(FBCT)=VAPA(FBI)
..S FBCT=FBCT+1,FBARR(FBCT)=$S(VAPA(4)]"":VAPA(4),1:" ")_" "_$S($P(VAPA(5),U,2)]"":$P(VAPA(5),U,2),1:" ")_" "_$S('+$G(VAPA(11)):VAPA(6),$P(VAPA(11),U,2)]"":$P(VAPA(11),U,2),1:VAPA(6))
S FBARR=FBCT
Q
;
VENADD(FBV,FBARR) ;set up vendor address
;INPUT: FBV = vendor ien (file 161.2)
; FBARR array that will hold the address (passed by reference)
;OUTPUT FBARR array will contain the vendor mailing address,
; subscripted by sequential number; FBARR = line count
N FBCT,FBP,FBSTATE,FBZ
K FBARR
S FBCT=0
I $G(FBV)>0 D
.S FBZ=$G(^FBAAV(FBV,0))
.S FBCT=FBCT+1,FBARR(FBCT)=$P(FBZ,U)
.I FBARR(1)["," S FBARR(1)=$P(FBARR(1),",",2)_" "_$P(FBARR(1),",")
.S FBSTATE=$P($G(^DIC(5,+$P(FBZ,U,5),0)),U,2)
.F FBP=3,14 S:$P(FBZ,U,FBP)]"" FBCT=FBCT+1,FBARR(FBCT)=$P(FBZ,U,FBP)
.S FBCT=FBCT+1,FBARR(FBCT)=$S($P(FBZ,U,4)]"":$P(FBZ,U,4),1:" ")_" "_$S(FBSTATE]"":FBSTATE,1:" ")_" "_$P(FBZ,U,6)
S FBARR=FBCT
Q
OTHADD(FBDA,FBARR) ;set up other party address
;INPUT: FBDA = other party ien (file 200)
; FBARR array that will hold the address (passed by reference)
;OUTPUT FBARR array will contain the vendor mailing address,
; subscripted by sequential number; FBARR = line count
N FBCT,FBP,FBSTATE,FBZ11
K FBARR
S FBCT=0
I $G(FBDA)>0 D
.S FBCT=FBCT+1,FBARR(FBCT)=$$GETNAME^FBUCLET1(FBDA,200,"G")
.S FBZ11=$G(^VA(200,FBDA,.11))
.I FBZ11]"" D
..S FBSTATE=$P($G(^DIC(5,+$P(FBZ11,U,5),0)),U,2)
..F FBP=1,2,3 S:$P(FBZ11,U,FBP)]"" FBCT=FBCT+1,FBARR(FBCT)=$P(FBZ11,U,FBP)
..S FBCT=FBCT+1,FBARR(FBCT)=$S($P(FBZ11,U,4)]"":$P(FBZ11,U,4),1:" ")_" "_$S(FBSTATE]"":FBSTATE,1:" ")_" "_$P(FBZ11,U,6)
S FBARR=FBCT
Q
STATADD ;station address, from fee basis site parameter file
;INPUT: nothing
;OUTPUT: FBSADD( array of station name,address, and number
;called when printing a letter, used if letterhead not used
K ^UTILITY("DIQ1",$J) N DIC,DA,DIQ,DR,FBCT,FBP S DIC="^FBAA(161.4,",DA=1,DIQ="FBSADD(" D
.S DR="1:2;16",DIQ(0)="EN" D EN^DIQ1
.S DR="3:5;35.6",DIQ(0)="E" D EN^DIQ1
.;S DR=27,DIQ(0)="IN" D EN^DIQ1
I $G(FBSADD(161.4,1,16,"E"))]"" S FBSADD(161.4,1,2.5,"E")=FBSADD(161.4,1,16,"E") K FBSADD(161.4,1,16,"E") ;set street address lines together
S FBSADD(161.4,1,.01,"E")=$G(FBSADD(161.4,1,35.6,"E")) K FBSADD(161.4,1,35.6,"E") ;re-set so name is first
S (FBCT,FBP)=0 F S FBP=$O(FBSADD(161.4,1,FBP)) Q:FBP'<3!('FBP) S:$G(FBSADD(161.4,1,FBP,"E"))]"" FBCT=FBCT+1,FBSADD(FBCT)=FBSADD(161.4,1,FBP,"E") K FBSADD(161.4,1,FBP)
S FBCT=FBCT+1,FBSADD(FBCT)=$S($G(FBSADD(161.4,1,3,"E"))]"":FBSADD(161.4,1,3,"E"),1:" ")_" "_$S($G(FBSADD(161.4,1,4,"E"))]"":FBSADD(161.4,1,4,"E"),1:" ")_" "_$G(FBSADD(161.4,1,5,"E")) F FBP=3:1:5 K FBSADD(161.4,1,FBP)
K ^UTILITY("DIQ1",$J) Q
STANUM ;get station number
;INPUT: nothing
;OUTPUT: FBSTANUM = station number of PSA, as set in FB site parameter
K ^UTILITY("DIQ1",$J) N DA,DIC,DIQ,DR S DA=1,DIC="^FBAA(161.4,",DIQ="FBSTA(",DR=27,DIQ(0)="IN" D EN^DIQ1 K ^UTILITY("DIQ1",$J)
S FBSTANUM=$G(FBSTA(161.4,1,27,"I")) I FBSTANUM]"" S FBSTANUM=$P($G(^DIC(4,FBSTANUM,99)),U)
K FBSTA(161.4) Q
LETTER(FBORDER,FB1725) ;get letter ien number
;INPUT: FBORDER = order number of status
; FB1725 = (optional) =true to select a 38 U.S.C. 1725 letter
;OUTPUT: ien of letter or 0
N Y,PIECE
S Y=+$O(^FB(162.92,"AO",FBORDER,0))
S PIECE=$S($G(FB1725):6,1:5)
Q +$P($G(^FB(162.92,Y,0)),"^",PIECE)
;
TXT(FBGL,FBIEN,FBN,DIWF,DIWL,FBLET,FBCC,FBCCI,FBLBL) ;write txt
;INPUT: FBGL = global root
; FBIEN = internal entry number of file
; FBN = node where wp info resides
; DIWF = format
; DIWL = left offset
; FBLET = 1 if coming from letter (optional)
; FBCC = 1 if CC address will print at bottom of page (optional)
; passed by reference
; FBCCI = number lines needed for CC address (required if FBCC=1)
; FBLBL = label text to print at beginning of 1st line (optional)
N FBI,FBNODE,FBTXT,X S FBNODE=FBGL_FBIEN_","_FBN S FBLET=$S('$D(FBLET):0,1:+FBLET)
I $D(@(FBNODE_")")) S X=$G(FBLBL) D:X]"" ^DIWP S FBI=0 F S FBI=$O(@(FBNODE_","_FBI_")")) Q:'FBI S FBTXT=^(FBI,0),X=FBTXT D
.I $Y+$S($G(FBCCI)>7&$G(FBCC):FBCCI,1:7)>IOSL W:'FBLET @IOF D:FBLET PAGE^FBUCLET1
.D ^DIWP
I $Y+$S($G(FBCCI)>7&$G(FBCC):FBCCI,1:7)>IOSL W:'FBLET @IOF D:FBLET PAGE^FBUCLET1
D:$D(FBTXT) ^DIWW
K FBLET Q
PAGE ;write page
W @IOF Q
PDATE(FBDT) ;output fcn of date, long form
;INPUT: FBDT = date for output
;OUTPUT: month day, year
N FBPDT,Y S Y=FBDT D PDATE^FBAAUTL Q $G(FBPDT)
;
FBUC(X) ;unauthorized claim parameters
;INPUT: X = ien of parameter
;OUTPUT: "UC" node in parameter file
Q $G(^FBAA(161.4,X,"UC"))
;
DIE(DIE,DA,DR) ;update a field
;INPUT: DIE = global root
; DA = record to be updated
; DR = field to be updated
;OUTPUT: update record in file
I $S($G(DIE)']"":1,$G(DR)']"":1,'+$G(DA):1,1:0) Q
N FBLOCK
D LOCK^FBUCUTL(DIE,DA,1) I FBLOCK D ^DIE L -@(DIE_DA_")") K FBLOCK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBUCUTL2 6787 printed Nov 22, 2024@17:10:41 Page 2
FBUCUTL2 ;ALBISC/TET - UTILITY (CONTINUED) ;2/12/2003
+1 ;;3.5;FEE BASIS;**23,32,38,52**;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
ADDRESS(FBUCA) ;set up address (FBADD) and carbon copy address (FBADDCC)
+1 ;INPUT: FBUCA = current (or after) zero node for UC (file #162.7)
+2 ;OUTPUT: FBADD( array, subscripted by sequential number; FBADD = count
+3 ; FBADDCC( array, subscripted by sequential number; FBADDCC=count
+4 NEW FBDA,FBGL,FBSUB
+5 KILL FBADD,FBADDCC
+6 SET FBSUB=$PIECE(FBUCA,U,23)
+7 if FBSUB']""
SET FBSUB=$PIECE(FBUCA,U,4)_";DPT("
+8 SET FBDA=+$PIECE(FBSUB,";")
+9 IF FBSUB["FBAAV"
DO VENADD(FBDA,.FBADD)
DO VETADD($PIECE(FBUCA,U,4),.FBADDCC)
+10 IF FBSUB["DPT"
DO VETADD(FBDA,.FBADD)
DO VENADD($PIECE(FBUCA,U,3),.FBADDCC)
+11 IF FBSUB["VA(200"
DO OTHADD(FBDA,.FBADD)
DO VETADD($PIECE(FBUCA,U,4),.FBADDCC)
+12 QUIT
VETADD(DFN,FBARR) ;set up veteran address
+1 ;INPUT: DFN = veteran ien
+2 ; FBARR array that will hold the address (passed by reference)
+3 ;VAPA("CD") - date for ADD^VADPT if not defined then NOW will be used
+4 ; VAPA will be killed!
+5 ;
+6 ;OUTPUT FBARR array will contain the veteran mailing address,
+7 ; subscripted by sequential number; FBARR = line count
+8 NEW FBCT,FBI
+9 KILL FBARR
+10 SET FBCT=0
+11 IF $GET(DFN)>0
Begin DoDot:1
+12 SET FBCT=FBCT+1
SET FBARR(FBCT)=$$GETNAME^FBUCLET1(DFN,2,"G")
+13 DO ADD^VADPT
IF 'VAERR
Begin DoDot:2
+14 IF $$ACTIVECC^FBAACO0()
Begin DoDot:3
+15 FOR FBI=13,14,15
if $GET(VAPA(FBI))]""
SET FBCT=FBCT+1
SET FBARR(FBCT)=$GET(VAPA(FBI))
+16 SET FBCT=FBCT+1
SET FBARR(FBCT)=$SELECT($GET(VAPA(16))]"":$GET(VAPA(16)),1:" ")_" "_$SELECT($PIECE($GET(VAPA(17)),U,2)]"":$PIECE($GET(VAPA(17)),U,2),1:" ")_" "_$PIECE($GET(VAPA(18)),U,2)
End DoDot:3
QUIT
+17 FOR FBI=1,2,3
if VAPA(FBI)]""
SET FBCT=FBCT+1
SET FBARR(FBCT)=VAPA(FBI)
+18 SET FBCT=FBCT+1
SET FBARR(FBCT)=$SELECT(VAPA(4)]"":VAPA(4),1:" ")_" "_$SELECT($PIECE(VAPA(5),U,2)]"":$PIECE(VAPA(5),U,2),1:" ")_" "_$SELECT('+$GET(VAPA(11)):VAPA(6),$PIECE(VAPA(11),U,2)]"":$PIECE(VAPA(11),U,2),1:VAPA(6))
End DoDot:2
KILL VAPA,VAERR
End DoDot:1
+19 SET FBARR=FBCT
+20 QUIT
+21 ;
VENADD(FBV,FBARR) ;set up vendor address
+1 ;INPUT: FBV = vendor ien (file 161.2)
+2 ; FBARR array that will hold the address (passed by reference)
+3 ;OUTPUT FBARR array will contain the vendor mailing address,
+4 ; subscripted by sequential number; FBARR = line count
+5 NEW FBCT,FBP,FBSTATE,FBZ
+6 KILL FBARR
+7 SET FBCT=0
+8 IF $GET(FBV)>0
Begin DoDot:1
+9 SET FBZ=$GET(^FBAAV(FBV,0))
+10 SET FBCT=FBCT+1
SET FBARR(FBCT)=$PIECE(FBZ,U)
+11 IF FBARR(1)[","
SET FBARR(1)=$PIECE(FBARR(1),",",2)_" "_$PIECE(FBARR(1),",")
+12 SET FBSTATE=$PIECE($GET(^DIC(5,+$PIECE(FBZ,U,5),0)),U,2)
+13 FOR FBP=3,14
if $PIECE(FBZ,U,FBP)]""
SET FBCT=FBCT+1
SET FBARR(FBCT)=$PIECE(FBZ,U,FBP)
+14 SET FBCT=FBCT+1
SET FBARR(FBCT)=$SELECT($PIECE(FBZ,U,4)]"":$PIECE(FBZ,U,4),1:" ")_" "_$SELECT(FBSTATE]"":FBSTATE,1:" ")_" "_$PIECE(FBZ,U,6)
End DoDot:1
+15 SET FBARR=FBCT
+16 QUIT
OTHADD(FBDA,FBARR) ;set up other party address
+1 ;INPUT: FBDA = other party ien (file 200)
+2 ; FBARR array that will hold the address (passed by reference)
+3 ;OUTPUT FBARR array will contain the vendor mailing address,
+4 ; subscripted by sequential number; FBARR = line count
+5 NEW FBCT,FBP,FBSTATE,FBZ11
+6 KILL FBARR
+7 SET FBCT=0
+8 IF $GET(FBDA)>0
Begin DoDot:1
+9 SET FBCT=FBCT+1
SET FBARR(FBCT)=$$GETNAME^FBUCLET1(FBDA,200,"G")
+10 SET FBZ11=$GET(^VA(200,FBDA,.11))
+11 IF FBZ11]""
Begin DoDot:2
+12 SET FBSTATE=$PIECE($GET(^DIC(5,+$PIECE(FBZ11,U,5),0)),U,2)
+13 FOR FBP=1,2,3
if $PIECE(FBZ11,U,FBP)]""
SET FBCT=FBCT+1
SET FBARR(FBCT)=$PIECE(FBZ11,U,FBP)
+14 SET FBCT=FBCT+1
SET FBARR(FBCT)=$SELECT($PIECE(FBZ11,U,4)]"":$PIECE(FBZ11,U,4),1:" ")_" "_$SELECT(FBSTATE]"":FBSTATE,1:" ")_" "_$PIECE(FBZ11,U,6)
End DoDot:2
End DoDot:1
+15 SET FBARR=FBCT
+16 QUIT
STATADD ;station address, from fee basis site parameter file
+1 ;INPUT: nothing
+2 ;OUTPUT: FBSADD( array of station name,address, and number
+3 ;called when printing a letter, used if letterhead not used
+4 KILL ^UTILITY("DIQ1",$JOB)
NEW DIC,DA,DIQ,DR,FBCT,FBP
SET DIC="^FBAA(161.4,"
SET DA=1
SET DIQ="FBSADD("
Begin DoDot:1
+5 SET DR="1:2;16"
SET DIQ(0)="EN"
DO EN^DIQ1
+6 SET DR="3:5;35.6"
SET DIQ(0)="E"
DO EN^DIQ1
+7 ;S DR=27,DIQ(0)="IN" D EN^DIQ1
End DoDot:1
+8 ;set street address lines together
IF $GET(FBSADD(161.4,1,16,"E"))]""
SET FBSADD(161.4,1,2.5,"E")=FBSADD(161.4,1,16,"E")
KILL FBSADD(161.4,1,16,"E")
+9 ;re-set so name is first
SET FBSADD(161.4,1,.01,"E")=$GET(FBSADD(161.4,1,35.6,"E"))
KILL FBSADD(161.4,1,35.6,"E")
+10 SET (FBCT,FBP)=0
FOR
SET FBP=$ORDER(FBSADD(161.4,1,FBP))
if FBP'<3!('FBP)
QUIT
if $GET(FBSADD(161.4,1,FBP,"E"))]""
SET FBCT=FBCT+1
SET FBSADD(FBCT)=FBSADD(161.4,1,FBP,"E")
KILL FBSADD(161.4,1,FBP)
+11 SET FBCT=FBCT+1
SET FBSADD(FBCT)=$SELECT($GET(FBSADD(161.4,1,3,"E"))]"":FBSADD(161.4,1,3,"E"),1:" ")_" "_$SELECT($GET(FBSADD(161.4,1,4,"E"))]"":FBSADD(161.4,1,4,"E"),1:" ")_" "_$GET(FBSADD(161.4,1,5,"E"))
FOR FBP=3:1:5
KILL FBSADD(161.4,1,FBP)
+12 KILL ^UTILITY("DIQ1",$JOB)
QUIT
STANUM ;get station number
+1 ;INPUT: nothing
+2 ;OUTPUT: FBSTANUM = station number of PSA, as set in FB site parameter
+3 KILL ^UTILITY("DIQ1",$JOB)
NEW DA,DIC,DIQ,DR
SET DA=1
SET DIC="^FBAA(161.4,"
SET DIQ="FBSTA("
SET DR=27
SET DIQ(0)="IN"
DO EN^DIQ1
KILL ^UTILITY("DIQ1",$JOB)
+4 SET FBSTANUM=$GET(FBSTA(161.4,1,27,"I"))
IF FBSTANUM]""
SET FBSTANUM=$PIECE($GET(^DIC(4,FBSTANUM,99)),U)
+5 KILL FBSTA(161.4)
QUIT
LETTER(FBORDER,FB1725) ;get letter ien number
+1 ;INPUT: FBORDER = order number of status
+2 ; FB1725 = (optional) =true to select a 38 U.S.C. 1725 letter
+3 ;OUTPUT: ien of letter or 0
+4 NEW Y,PIECE
+5 SET Y=+$ORDER(^FB(162.92,"AO",FBORDER,0))
+6 SET PIECE=$SELECT($GET(FB1725):6,1:5)
+7 QUIT +$PIECE($GET(^FB(162.92,Y,0)),"^",PIECE)
+8 ;
TXT(FBGL,FBIEN,FBN,DIWF,DIWL,FBLET,FBCC,FBCCI,FBLBL) ;write txt
+1 ;INPUT: FBGL = global root
+2 ; FBIEN = internal entry number of file
+3 ; FBN = node where wp info resides
+4 ; DIWF = format
+5 ; DIWL = left offset
+6 ; FBLET = 1 if coming from letter (optional)
+7 ; FBCC = 1 if CC address will print at bottom of page (optional)
+8 ; passed by reference
+9 ; FBCCI = number lines needed for CC address (required if FBCC=1)
+10 ; FBLBL = label text to print at beginning of 1st line (optional)
+11 NEW FBI,FBNODE,FBTXT,X
SET FBNODE=FBGL_FBIEN_","_FBN
SET FBLET=$SELECT('$DATA(FBLET):0,1:+FBLET)
+12 IF $DATA(@(FBNODE_")"))
SET X=$GET(FBLBL)
if X]""
DO ^DIWP
SET FBI=0
FOR
SET FBI=$ORDER(@(FBNODE_","_FBI_")"))
if 'FBI
QUIT
SET FBTXT=^(FBI,0)
SET X=FBTXT
Begin DoDot:1
+13 IF $Y+$SELECT($GET(FBCCI)>7&$GET(FBCC):FBCCI,1:7)>IOSL
if 'FBLET
WRITE @IOF
if FBLET
DO PAGE^FBUCLET1
+14 DO ^DIWP
End DoDot:1
+15 IF $Y+$SELECT($GET(FBCCI)>7&$GET(FBCC):FBCCI,1:7)>IOSL
if 'FBLET
WRITE @IOF
if FBLET
DO PAGE^FBUCLET1
+16 if $DATA(FBTXT)
DO ^DIWW
+17 KILL FBLET
QUIT
PAGE ;write page
+1 WRITE @IOF
QUIT
PDATE(FBDT) ;output fcn of date, long form
+1 ;INPUT: FBDT = date for output
+2 ;OUTPUT: month day, year
+3 NEW FBPDT,Y
SET Y=FBDT
DO PDATE^FBAAUTL
QUIT $GET(FBPDT)
+4 ;
FBUC(X) ;unauthorized claim parameters
+1 ;INPUT: X = ien of parameter
+2 ;OUTPUT: "UC" node in parameter file
+3 QUIT $GET(^FBAA(161.4,X,"UC"))
+4 ;
DIE(DIE,DA,DR) ;update a field
+1 ;INPUT: DIE = global root
+2 ; DA = record to be updated
+3 ; DR = field to be updated
+4 ;OUTPUT: update record in file
+5 IF $SELECT($GET(DIE)']"":1,$GET(DR)']"":1,'+$GET(DA):1,1:0)
QUIT
+6 NEW FBLOCK
+7 DO LOCK^FBUCUTL(DIE,DA,1)
IF FBLOCK
DO ^DIE
LOCK -@(DIE_DA_")")
KILL FBLOCK
+8 QUIT
