FBUCLET1 ;ALBISC/TET - UNAUTHORIZED CLAIM LETTER (continued) ;29/NOV/2006
;;3.5;FEE BASIS;**12,23,32,38,101**;JAN 30, 1995;Build 2
;;Per VHA Directive 2004-038, this routine should not be modified.
PRINT ;print letter, don't update if variable fbnoup exists
;INPUT: FBDA = ien of unauthorized claim, file 162.7
; FBORDER = (optional) order number of status
; FBUCA = current (after) zero node of unauthorized claim (162.7)
; FBUC = unauthorized claim node in parameter file
; FBNOUP = 1 if no update is to occur, optional, set in reprint
; FBFF = counter flag, suppresses formfeed if = 0
; FBCOPIES = # of copies to print, optional, not set from auto
; FBSTANUM = station number
; FBSADD( array = station address, if site parameter designates letterhead not used
;VAR FBADD( = address array to where letter is mailed
; FBADDCC( = address array for carbon copy
; FBCC = flag, true if CC address should print at bottom of page
; FBCCI = # used to determine where CC address prints
; FBTAMT = $ amount calculated in routine FBUCLET2 for an
; approved or approved to stabilization disposition
; letter. Used to populate field #14 in file #162.7.
;OUTPUT: none - print letter and update fields, if '$d(fbnoup), upon completion
N FBADD,FBADDCC,FBAUTH,FBC,FBEP,FBLETDT,FBLIEN,FBMCODE,FBNAM,FBNAM1
N FBPROG,FBRE,FBSUBMIT,FBTAMT,FBCC,FBCCI
S FBLETDT=0 S:FBORDER']"" FBORDER=$$ORDER^FBUCUTL(FBDA) S ZTSTOP=$$S^%ZTLOAD
D ADDRESS^FBUCUTL2(FBUCA)
S FBSUBMIT=$P(FBUCA,U,23),FBPROG=$$PROG^FBUCUTL(+$P(FBUCA,U,2))
S FBNAM=$S(FBSUBMIT["FBAAV("!(FBSUBMIT["VA(200,"):$$VET^FBUCUTL(+$P(FBUCA,U,4)),1:$$VEN^FBUCUTL(+$P(FBUCA,U,3))) I FBNAM["," S FBNAM=$P(FBNAM,",",2)_" "_$P(FBNAM,",")
I FBSUBMIT'["DPT(" S FBNAM1=$$VEN^FBUCUTL(+$P(FBUCA,U,3)) I FBNAM1["," S FBNAM1=$P(FBNAM1,",",2)_" "_$P(FBNAM1,",")
;
; Utilize new API for Name Standardization
;
I FBNAM'="UNKNOWN",FBSUBMIT["FBAAV("!(FBSUBMIT["VA(200,") D
.S FBNAM=$$GETNAME(+$P(FBUCA,U,4),2,"G","")
.Q
;
S FBRE=$S(FBSUBMIT']""!(FBSUBMIT["DPT("):"VENDOR:",1:"VETERAN:")
S FBEP=$$FMTE^XLFDT(+$P(FBUCA,U,5)) S:$P(FBUCA,U,6)'=$P(FBUCA,U,5) FBEP=FBEP_"^"_$$FMTE^XLFDT(+$P(FBUCA,U,6))
S FBAUTH=$$FMTE^XLFDT(+$P(FBUCA,U,13)) S:$P(FBUCA,U,14)'=$P(FBUCA,U,13) FBAUTH=FBAUTH_"^"_$$FMTE^XLFDT(+$P(FBUCA,U,14))
S FBLIEN=$$LETTER^FBUCUTL2(FBORDER,+$P(FBUCA,U,28))
S FBMCODE=$$GET1^DIQ(161.4,1,5.5) ; Load Mail Code
I '$D(FBCOPIES) S FBCOPIES=$S($P(FBUC,U,4):$P(FBUC,U,4),1:1)
I FBLIEN F FBC=1:1:FBCOPIES D
.N DIWF,DIWL,FBEXP,FBI,FBDL1
.;set flag true when disposition letter to indicate that a CC address
.;needs to be printed at the bottom of the first page
.S FBCC=$S(FBORDER>20:1,1:0)
.;set FBCCI = blank lines before address (2) + max address lines (5) +
.; # of lines after address from site parameters + a constant (2)
.;S FBCCI=2+5+$S($P(FBUC,U,10)]"":$P(FBUC,U,10),1:9)+2 ; default param
.S FBCCI=2+5+$P(FBUC,U,10)+2
.S FBFF=FBFF+1 W:FBFF&(FBFF>1) @IOF W !
.W:$P(FBUC,U,8) !!!!! D:'$P(FBUC,U,8)
..N FBI,FBX,FBCT S (FBCT,FBI)=0 F S FBI=$O(FBSADD(FBI)) Q:'FBI S FBX=FBSADD(FBI) W !?(IOM-$L(FBX)/2),FBX S FBCT=FBCT+1
..S FBCT=5-FBCT I FBCT>0 F FBI=1:1:FBCT W ! ;ensure length of header is consistant
.W !?4,$$PDATE^FBUCUTL2(DT),!
.W:'$P(FBUC,U,8) ?47,"In Reply Refer To: " W ?66,FBSTANUM,"/",FBMCODE
.W !?50,$$GETNAME(+$P(FBUCA,U,4),2,"F","C")
.S (FBCT,FBI)=0 F S FBI=$O(FBADD(FBI)) Q:'FBI W !?4,FBADD(FBI) S FBCT=FBCT+1 I FBI=1 W ?50,$$SSNL4^FBAAUTL($$SSN^FBAAUTL(+$P(FBUCA,U,4)))
.D HED
.S DIWF="WC79I4",DIWL=1 D:$Y+$S(FBCCI>10&FBCC:FBCCI,1:10)>IOSL PAGE D TXT^FBUCUTL2("^FBAA(161.3,",FBLIEN,1,DIWF,DIWL,1,.FBCC,FBCCI) W !
.S DIWF="WC72I8",DIWL=1
.I FBORDER>20 D:$Y+$S(FBCCI>10&FBCC:FBCCI,1:10)>IOSL PAGE D TXT^FBUCUTL2("^FB(162.91,",+$P(FBUCA,U,11),$S(+$P(FBUCA,U,28):2,1:1),DIWF,DIWL,1,.FBCC,FBCCI) D
..; if approved (or approved to stabilization) then include details
..I $P(FBUCA,U,11)=1!($P(FBUCA,U,11)=4) D AUTHPR^FBUCLET2
..I +$P(FBUCA,U,11)'=1,+$O(^FB583(FBDA,"D",0)) D:$Y+$S(FBCCI>10&FBCC:FBCCI,1:10)>IOSL PAGE W !?8,"Reason(s) for not approving "_$S($P(FBUCA,U,11)=4:"entire ",1:"")_"claim:" D
...N DIWF,FBI,FBZ S DIWF="WC69I8",FBI=0 F S FBI=$O(^FB583(FBDA,"D",FBI)) Q:'FBI S FBZ=^(FBI,0) D:$Y+$S(FBCCI>8&FBCC:FBCCI,1:8)>IOSL PAGE W ! D TXT^FBUCUTL2("^FB(162.94,",+FBZ,1,DIWF,DIWL,1,.FBCC,FBCCI)
..;
..;print optional disposition remarks for the claim
..I FBORDER>20 D
...N DIWF,DIWL,FBN
...; select appropriate wp field based on status (appeal, cova, initial)
...S FBN=$S(FBORDER=70:"""A1""",FBORDER=90:"""A2""",1:4)
...Q:'$O(^FB583(FBDA,FBN,0)) ; no remarks on file
...D:$Y+$S(FBCCI>7&FBCC:FBCCI,1:7)>IOSL PAGE
...W !
...S DIWF="WC72I8",DIWL=1
...D TXT^FBUCUTL2("^FB583(",FBDA,FBN,DIWF,DIWL,1,.FBCC,FBCCI)
..;
..;print additional description text (if any) for disposition
..I $O(^FB(162.91,+$P(FBUCA,U,11),3,0)) D
...N DIWF,DIWL
...D:$Y+$S(FBCCI>10&FBCC:FBCCI,1:10)>IOSL PAGE
...W !
...S DIWF="WC72I8",DIWL=1
...D TXT^FBUCUTL2("^FB(162.91,",+$P(FBUCA,U,11),3,DIWF,DIWL,1,.FBCC,FBCCI)
.I FBORDER'>20 S FBI=0 F S FBI=$O(^FBAA(162.8,"AC",FBDA,FBI)) Q:'FBI S FBZ=$G(^FBAA(162.8,FBI,0)) I '$P(FBZ,U,5) D:$Y+$S(FBCCI>12&FBCC:FBCCI,1:12)>IOSL PAGE D
..N FBX W ! S FBX=$P($G(^FB(162.93,+$P(FBZ,U,3),0)),U) I FBX="OTHER" S:$P(FBZ,U,4)]"" FBX=$P(FBZ,U,4) W ?8,FBX,! Q
..D TXT^FBUCUTL2("^FB(162.93,",+$P(FBZ,U,3),1,DIWF,DIWL,1,.FBCC,FBCCI)
.S DIWF="WC79I4",DIWL=1 D:($Y+4+$S(FBCCI>$S(FBORDER>20:15,1:22)&FBCC:FBCCI,FBORDER>20:15,1:22))>IOSL PAGE W ! D TXT^FBUCUTL2("^FBAA(161.3,",FBLIEN,2,DIWF,DIWL,1,.FBCC,FBCCI)
.;print postscript (if any) on request info. letter
.I FBORDER'>20 S FBI=0 F S FBI=$O(^FBAA(162.8,"AC",FBDA,FBI)) Q:'FBI S FBZ=$G(^FBAA(162.8,FBI,0)) I '$P(FBZ,U,5) D
..N FBX,FBPS
..Q:'$O(^FB(162.93,+$P(FBZ,U,3),2,0)) ; no postscript to print
..;start new page
..S FBPS=1 D PAGE S FBPS=0
..W !!
..;print text
..S FBX=$P($G(^FB(162.93,+$P(FBZ,U,3),0)),U)
..I FBX="SIGNED STATEMENT FROM CLAIMANT",$P(FBZ,U,4)]"",$E($P(FBZ,U,4),1)=0 D
...; just print statement since user specified that regulations should
...; not be printed (stop after line 11 of postscript)
...N FBI,FBTXT
...S FBI=0 F S FBI=$O(^FB(162.93,+$P(FBZ,U,3),2,FBI)) Q:FBI>11!'FBI D
....S FBTXT=^FB(162.93,+$P(FBZ,U,3),2,FBI,0),X=FBTXT
....I $Y+$S(FBCCI>7&FBCC:FBCCI,1:7)>IOSL D PAGE
....D ^DIWP
...I $Y+$S(FBCCI>7&FBCC:FBCCI,1:7)>IOSL D PAGE
...D:$D(FBTXT) ^DIWW
..E D TXT^FBUCUTL2("^FB(162.93,",+$P(FBZ,U,3),2,DIWF,DIWL,1,.FBCC,FBCCI) ;entire ps
.;if still on 1st page of disposition letter then print the CC address
.I FBCC D CCADDR
;
I '$D(FBNOUP) D
.D:$D(XRTL) T0^%ZOSV ;start monitor
.S FBEXP=$$EXPIRE^FBUCUTL8(FBDA,DT,FBUCA,FBORDER)
.D EDITL^FBUCED(FBDA,FBEXP,"@",DT,$G(FBTAMT))
.S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV ;stop monitor
Q
;
GETNAME(FBIEN,FBFILE,FBFMT,FBFLAG) ;
N FBNAMES
I FBIEN=""!(FBFILE)="" Q "" ; Quit if there is no IEN or File number
S FBFMT=$G(FBFMT),FBFLAG=$G(FBFLAG)
S FBNAMES("FILE")=FBFILE,FBNAMES("IENS")=FBIEN,FBNAMES("FIELD")=.01
S FBNAMES=$$NAMEFMT^XLFNAME(.FBNAMES,FBFMT,FBFLAG)
Q FBNAMES
;
PAGE ;new page
;print CC address at bottom of 1st page on disposition letters
I FBCC D CCADDR
W @IOF,!!!!!!!
; if called from 1st page of postscript print then include more info
I $G(FBPS)=1 D
.W:'$P(FBUC,U,8) ?47,"In Reply Refer To: " W ?66,FBSTANUM,"/",FBMCODE
.W !?50,$$GETNAME(+$P(FBUCA,U,4),2,"F","C")
.W !?50,$$SSNL4^FBAAUTL($$SSN^FBAAUTL(+$P(FBUCA,U,4)))
HED ;header to print after address and on each new page
W !!!!?8,"REGARDING:",?20,FBRE,?38,FBNAM I $D(FBNAM1) W !?20,"VENDOR:",?38,FBNAM1
W !?20,"FEE PROGRAM:",?38,FBPROG
W !?20,"EPISODE OF CARE:",?38,$P(FBEP,U) W:$P(FBEP,U,2)]"" " to ",$P(FBEP,U,2)
W !!
Q
CCADDR ; print CC address at bottom of page
; advance to bottom of page
N FBI
F FBI=$Y+FBCCI-1:1:$S(IOSL>120:$Y+FBCCI,1:IOSL) W !
; print CC address lines
S FBI=0
F S FBI=$O(FBADDCC(FBI)) Q:'FBI W ! W:FBI=1 " CC:" W ?4,FBADDCC(FBI)
;set flag to false since CC address has been printed
S FBCC=0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBUCLET1 8285 printed Dec 13, 2024@02:00:17 Page 2
FBUCLET1 ;ALBISC/TET - UNAUTHORIZED CLAIM LETTER (continued) ;29/NOV/2006
+1 ;;3.5;FEE BASIS;**12,23,32,38,101**;JAN 30, 1995;Build 2
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
PRINT ;print letter, don't update if variable fbnoup exists
+1 ;INPUT: FBDA = ien of unauthorized claim, file 162.7
+2 ; FBORDER = (optional) order number of status
+3 ; FBUCA = current (after) zero node of unauthorized claim (162.7)
+4 ; FBUC = unauthorized claim node in parameter file
+5 ; FBNOUP = 1 if no update is to occur, optional, set in reprint
+6 ; FBFF = counter flag, suppresses formfeed if = 0
+7 ; FBCOPIES = # of copies to print, optional, not set from auto
+8 ; FBSTANUM = station number
+9 ; FBSADD( array = station address, if site parameter designates letterhead not used
+10 ;VAR FBADD( = address array to where letter is mailed
+11 ; FBADDCC( = address array for carbon copy
+12 ; FBCC = flag, true if CC address should print at bottom of page
+13 ; FBCCI = # used to determine where CC address prints
+14 ; FBTAMT = $ amount calculated in routine FBUCLET2 for an
+15 ; approved or approved to stabilization disposition
+16 ; letter. Used to populate field #14 in file #162.7.
+17 ;OUTPUT: none - print letter and update fields, if '$d(fbnoup), upon completion
+18 NEW FBADD,FBADDCC,FBAUTH,FBC,FBEP,FBLETDT,FBLIEN,FBMCODE,FBNAM,FBNAM1
+19 NEW FBPROG,FBRE,FBSUBMIT,FBTAMT,FBCC,FBCCI
+20 SET FBLETDT=0
if FBORDER']""
SET FBORDER=$$ORDER^FBUCUTL(FBDA)
SET ZTSTOP=$$S^%ZTLOAD
+21 DO ADDRESS^FBUCUTL2(FBUCA)
+22 SET FBSUBMIT=$PIECE(FBUCA,U,23)
SET FBPROG=$$PROG^FBUCUTL(+$PIECE(FBUCA,U,2))
+23 SET FBNAM=$SELECT(FBSUBMIT["FBAAV("!(FBSUBMIT["VA(200,"):$$VET^FBUCUTL(+$PIECE(FBUCA,U,4)),1:$$VEN^FBUCUTL(+$PIECE(FBUCA,U,3)))
IF FBNAM[","
SET FBNAM=$PIECE(FBNAM,",",2)_" "_$PIECE(FBNAM,",")
+24 IF FBSUBMIT'["DPT("
SET FBNAM1=$$VEN^FBUCUTL(+$PIECE(FBUCA,U,3))
IF FBNAM1[","
SET FBNAM1=$PIECE(FBNAM1,",",2)_" "_$PIECE(FBNAM1,",")
+25 ;
+26 ; Utilize new API for Name Standardization
+27 ;
+28 IF FBNAM'="UNKNOWN"
IF FBSUBMIT["FBAAV("!(FBSUBMIT["VA(200,")
Begin DoDot:1
+29 SET FBNAM=$$GETNAME(+$PIECE(FBUCA,U,4),2,"G","")
+30 QUIT
End DoDot:1
+31 ;
+32 SET FBRE=$SELECT(FBSUBMIT']""!(FBSUBMIT["DPT("):"VENDOR:",1:"VETERAN:")
+33 SET FBEP=$$FMTE^XLFDT(+$PIECE(FBUCA,U,5))
if $PIECE(FBUCA,U,6)'=$PIECE(FBUCA,U,5)
SET FBEP=FBEP_"^"_$$FMTE^XLFDT(+$PIECE(FBUCA,U,6))
+34 SET FBAUTH=$$FMTE^XLFDT(+$PIECE(FBUCA,U,13))
if $PIECE(FBUCA,U,14)'=$PIECE(FBUCA,U,13)
SET FBAUTH=FBAUTH_"^"_$$FMTE^XLFDT(+$PIECE(FBUCA,U,14))
+35 SET FBLIEN=$$LETTER^FBUCUTL2(FBORDER,+$PIECE(FBUCA,U,28))
+36 ; Load Mail Code
SET FBMCODE=$$GET1^DIQ(161.4,1,5.5)
+37 IF '$DATA(FBCOPIES)
SET FBCOPIES=$SELECT($PIECE(FBUC,U,4):$PIECE(FBUC,U,4),1:1)
+38 IF FBLIEN
FOR FBC=1:1:FBCOPIES
Begin DoDot:1
+39 NEW DIWF,DIWL,FBEXP,FBI,FBDL1
+40 ;set flag true when disposition letter to indicate that a CC address
+41 ;needs to be printed at the bottom of the first page
+42 SET FBCC=$SELECT(FBORDER>20:1,1:0)
+43 ;set FBCCI = blank lines before address (2) + max address lines (5) +
+44 ; # of lines after address from site parameters + a constant (2)
+45 ;S FBCCI=2+5+$S($P(FBUC,U,10)]"":$P(FBUC,U,10),1:9)+2 ; default param
+46 SET FBCCI=2+5+$PIECE(FBUC,U,10)+2
+47 SET FBFF=FBFF+1
if FBFF&(FBFF>1)
WRITE @IOF
WRITE !
+48 if $PIECE(FBUC,U,8)
WRITE !!!!!
if '$PIECE(FBUC,U,8)
Begin DoDot:2
+49 NEW FBI,FBX,FBCT
SET (FBCT,FBI)=0
FOR
SET FBI=$ORDER(FBSADD(FBI))
if 'FBI
QUIT
SET FBX=FBSADD(FBI)
WRITE !?(IOM-$LENGTH(FBX)/2),FBX
SET FBCT=FBCT+1
+50 ;ensure length of header is consistant
SET FBCT=5-FBCT
IF FBCT>0
FOR FBI=1:1:FBCT
WRITE !
End DoDot:2
+51 WRITE !?4,$$PDATE^FBUCUTL2(DT),!
+52 if '$PIECE(FBUC,U,8)
WRITE ?47,"In Reply Refer To: "
WRITE ?66,FBSTANUM,"/",FBMCODE
+53 WRITE !?50,$$GETNAME(+$PIECE(FBUCA,U,4),2,"F","C")
+54 SET (FBCT,FBI)=0
FOR
SET FBI=$ORDER(FBADD(FBI))
if 'FBI
QUIT
WRITE !?4,FBADD(FBI)
SET FBCT=FBCT+1
IF FBI=1
WRITE ?50,$$SSNL4^FBAAUTL($$SSN^FBAAUTL(+$PIECE(FBUCA,U,4)))
+55 DO HED
+56 SET DIWF="WC79I4"
SET DIWL=1
if $Y+$SELECT(FBCCI>10&FBCC
DO PAGE
DO TXT^FBUCUTL2("^FBAA(161.3,",FBLIEN,1,DIWF,DIWL,1,.FBCC,FBCCI)
WRITE !
+57 SET DIWF="WC72I8"
SET DIWL=1
+58 IF FBORDER>20
if $Y+$SELECT(FBCCI>10&FBCC
DO PAGE
DO TXT^FBUCUTL2("^FB(162.91,",+$PIECE(FBUCA,U,11),$SELECT(+$PIECE(FBUCA,U,28):2,1:1),DIWF,DIWL,1,.FBCC,FBCCI)
Begin DoDot:2
+59 ; if approved (or approved to stabilization) then include details
+60 IF $PIECE(FBUCA,U,11)=1!($PIECE(FBUCA,U,11)=4)
DO AUTHPR^FBUCLET2
+61 IF +$PIECE(FBUCA,U,11)'=1
IF +$ORDER(^FB583(FBDA,"D",0))
if $Y+$SELECT(FBCCI>10&FBCC
DO PAGE
WRITE !?8,"Reason(s) for not approving "_$SELECT($PIECE(FBUCA,U,11)=4:"entire ",1:"")_"claim:"
Begin DoDot:3
+62 NEW DIWF,FBI,FBZ
SET DIWF="WC69I8"
SET FBI=0
FOR
SET FBI=$ORDER(^FB583(FBDA,"D",FBI))
if 'FBI
QUIT
SET FBZ=^(FBI,0)
if $Y+$SELECT(FBCCI>8&FBCC
DO PAGE
WRITE !
DO TXT^FBUCUTL2("^FB(162.94,",+FBZ,1,DIWF,DIWL,1,.FBCC,FBCCI)
End DoDot:3
+63 ;
+64 ;print optional disposition remarks for the claim
+65 IF FBORDER>20
Begin DoDot:3
+66 NEW DIWF,DIWL,FBN
+67 ; select appropriate wp field based on status (appeal, cova, initial)
+68 SET FBN=$SELECT(FBORDER=70:"""A1""",FBORDER=90:"""A2""",1:4)
+69 ; no remarks on file
if '$ORDER(^FB583(FBDA,FBN,0))
QUIT
+70 if $Y+$SELECT(FBCCI>7&FBCC
DO PAGE
+71 WRITE !
+72 SET DIWF="WC72I8"
SET DIWL=1
+73 DO TXT^FBUCUTL2("^FB583(",FBDA,FBN,DIWF,DIWL,1,.FBCC,FBCCI)
End DoDot:3
+74 ;
+75 ;print additional description text (if any) for disposition
+76 IF $ORDER(^FB(162.91,+$PIECE(FBUCA,U,11),3,0))
Begin DoDot:3
+77 NEW DIWF,DIWL
+78 if $Y+$SELECT(FBCCI>10&FBCC
DO PAGE
+79 WRITE !
+80 SET DIWF="WC72I8"
SET DIWL=1
+81 DO TXT^FBUCUTL2("^FB(162.91,",+$PIECE(FBUCA,U,11),3,DIWF,DIWL,1,.FBCC,FBCCI)
End DoDot:3
End DoDot:2
+82 IF FBORDER'>20
SET FBI=0
FOR
SET FBI=$ORDER(^FBAA(162.8,"AC",FBDA,FBI))
if 'FBI
QUIT
SET FBZ=$GET(^FBAA(162.8,FBI,0))
IF '$PIECE(FBZ,U,5)
if $Y+$SELECT(FBCCI>12&FBCC
DO PAGE
Begin DoDot:2
+83 NEW FBX
WRITE !
SET FBX=$PIECE($GET(^FB(162.93,+$PIECE(FBZ,U,3),0)),U)
IF FBX="OTHER"
if $PIECE(FBZ,U,4)]""
SET FBX=$PIECE(FBZ,U,4)
WRITE ?8,FBX,!
QUIT
+84 DO TXT^FBUCUTL2("^FB(162.93,",+$PIECE(FBZ,U,3),1,DIWF,DIWL,1,.FBCC,FBCCI)
End DoDot:2
+85 SET DIWF="WC79I4"
SET DIWL=1
if ($Y+4+$SELECT(FBCCI>$SELECT(FBORDER>20
DO PAGE
WRITE !
DO TXT^FBUCUTL2("^FBAA(161.3,",FBLIEN,2,DIWF,DIWL,1,.FBCC,FBCCI)
+86 ;print postscript (if any) on request info. letter
+87 IF FBORDER'>20
SET FBI=0
FOR
SET FBI=$ORDER(^FBAA(162.8,"AC",FBDA,FBI))
if 'FBI
QUIT
SET FBZ=$GET(^FBAA(162.8,FBI,0))
IF '$PIECE(FBZ,U,5)
Begin DoDot:2
+88 NEW FBX,FBPS
+89 ; no postscript to print
if '$ORDER(^FB(162.93,+$PIECE(FBZ,U,3),2,0))
QUIT
+90 ;start new page
+91 SET FBPS=1
DO PAGE
SET FBPS=0
+92 WRITE !!
+93 ;print text
+94 SET FBX=$PIECE($GET(^FB(162.93,+$PIECE(FBZ,U,3),0)),U)
+95 IF FBX="SIGNED STATEMENT FROM CLAIMANT"
IF $PIECE(FBZ,U,4)]""
IF $EXTRACT($PIECE(FBZ,U,4),1)=0
Begin DoDot:3
+96 ; just print statement since user specified that regulations should
+97 ; not be printed (stop after line 11 of postscript)
+98 NEW FBI,FBTXT
+99 SET FBI=0
FOR
SET FBI=$ORDER(^FB(162.93,+$PIECE(FBZ,U,3),2,FBI))
if FBI>11!'FBI
QUIT
Begin DoDot:4
+100 SET FBTXT=^FB(162.93,+$PIECE(FBZ,U,3),2,FBI,0)
SET X=FBTXT
+101 IF $Y+$SELECT(FBCCI>7&FBCC:FBCCI,1:7)>IOSL
DO PAGE
+102 DO ^DIWP
End DoDot:4
+103 IF $Y+$SELECT(FBCCI>7&FBCC:FBCCI,1:7)>IOSL
DO PAGE
+104 if $DATA(FBTXT)
DO ^DIWW
End DoDot:3
+105 ;entire ps
IF '$TEST
DO TXT^FBUCUTL2("^FB(162.93,",+$PIECE(FBZ,U,3),2,DIWF,DIWL,1,.FBCC,FBCCI)
End DoDot:2
+106 ;if still on 1st page of disposition letter then print the CC address
+107 IF FBCC
DO CCADDR
End DoDot:1
+108 ;
+109 IF '$DATA(FBNOUP)
Begin DoDot:1
+110 ;start monitor
if $DATA(XRTL)
DO T0^%ZOSV
+111 SET FBEXP=$$EXPIRE^FBUCUTL8(FBDA,DT,FBUCA,FBORDER)
+112 DO EDITL^FBUCED(FBDA,FBEXP,"@",DT,$GET(FBTAMT))
+113 ;stop monitor
if $DATA(XRT0)
SET XRTN=$TEXT(+0)
if $DATA(XRT0)
DO T1^%ZOSV
End DoDot:1
+114 QUIT
+115 ;
GETNAME(FBIEN,FBFILE,FBFMT,FBFLAG) ;
+1 NEW FBNAMES
+2 ; Quit if there is no IEN or File number
IF FBIEN=""!(FBFILE)=""
QUIT ""
+3 SET FBFMT=$GET(FBFMT)
SET FBFLAG=$GET(FBFLAG)
+4 SET FBNAMES("FILE")=FBFILE
SET FBNAMES("IENS")=FBIEN
SET FBNAMES("FIELD")=.01
+5 SET FBNAMES=$$NAMEFMT^XLFNAME(.FBNAMES,FBFMT,FBFLAG)
+6 QUIT FBNAMES
+7 ;
PAGE ;new page
+1 ;print CC address at bottom of 1st page on disposition letters
+2 IF FBCC
DO CCADDR
+3 WRITE @IOF,!!!!!!!
+4 ; if called from 1st page of postscript print then include more info
+5 IF $GET(FBPS)=1
Begin DoDot:1
+6 if '$PIECE(FBUC,U,8)
WRITE ?47,"In Reply Refer To: "
WRITE ?66,FBSTANUM,"/",FBMCODE
+7 WRITE !?50,$$GETNAME(+$PIECE(FBUCA,U,4),2,"F","C")
+8 WRITE !?50,$$SSNL4^FBAAUTL($$SSN^FBAAUTL(+$PIECE(FBUCA,U,4)))
End DoDot:1
HED ;header to print after address and on each new page
+1 WRITE !!!!?8,"REGARDING:",?20,FBRE,?38,FBNAM
IF $DATA(FBNAM1)
WRITE !?20,"VENDOR:",?38,FBNAM1
+2 WRITE !?20,"FEE PROGRAM:",?38,FBPROG
+3 WRITE !?20,"EPISODE OF CARE:",?38,$PIECE(FBEP,U)
if $PIECE(FBEP,U,2)]""
WRITE " to ",$PIECE(FBEP,U,2)
+4 WRITE !!
+5 QUIT
CCADDR ; print CC address at bottom of page
+1 ; advance to bottom of page
+2 NEW FBI
+3 FOR FBI=$Y+FBCCI-1:1:$SELECT(IOSL>120:$Y+FBCCI,1:IOSL)
WRITE !
+4 ; print CC address lines
+5 SET FBI=0
+6 FOR
SET FBI=$ORDER(FBADDCC(FBI))
if 'FBI
QUIT
WRITE !
if FBI=1
WRITE " CC:"
WRITE ?4,FBADDCC(FBI)
+7 ;set flag to false since CC address has been printed
+8 SET FBCC=0
+9 QUIT
