FBAAV4 ;AISC/GRR-ELECTRONICALLY TRANSMIT PATIENT MRA'S ;12/16/2003
;;3.5;FEE BASIS;**13,34,37,70,146,127,153,158**;JAN 30, 1995;Build 94
;;Per VA Directive 6402, this routine should not be modified.
;
;FB*3.5*153 Modify MRA transmission to Austin to insure that a
; undefined state code defaults to 2 spaces.
; Also, delete the entry in file 161.26 if no auth
; pointer exists in record or the auth pointer points
; to deleted patient authorization. In addition,
; insure processing continues if error condition
; and less than 100 stacked msgs for transmission.
;
;D STATION^FBAAUTL,HD^FBAAUTL Q:$D(FB("ERROR"))
S FBTXT=0,ZMCNT=1 ;FBTXT , ZMCNT
GO S J=0 F S J=$O(^FBAA(161.26,"AC","P",J)) Q:J'>0 S FB0=$G(^FBAA(161.26,J,0)) I $P(FB0,U) S Y(0)=$G(^DPT($P(FB0,U),0)) I Y(0)]"" S FBTYPE=$S($P(FB0,U,4)]"":$P(FB0,U,4),1:"A"),FBFDC=$P(FB0,U,6),FBMST=$P(FB0,U,7) D
.; GETBT-prepare header
.; NEWMSG^FBAAV01-get new message number, reset line counter, set subject line
.; STORE^FBAAV01- increment line counter and store in ^XMB
.; FBLN -line counter; FBFEE- "FEE message" counter; FBOKTX=1 if message pending, 0 otherwise
.I 'FBTXT S FBTXT=1 D GETBT,NEWMSG^FBAAV01,STORE^FBAAV01
.; prepare and store patient MRA portion (can be more than 1)
.D GOT
D:ZMCNT>1 XMIT^FBAAV01 ;FB*3.5*153
Q
;GETBT - prepare the "header" of the message
GETBT D GETNXB^FBAAUTL ;get next batch # in FBBN
S FBZBN=$E("0000000",$L(FBBN)+1,7)_FBBN ;FB*3.5*158
S FBSN=FBSN_$E(" ",$L(FBSN)+1,6)
S FBSTR=FBHD_"C2"_$E(DT,4,7)_$E(DT,2,3)_FBSN_FBZBN_"$"
Q
;
GOT ;patient MRA portion of the message
N FBCCFLG,FBPATICN,FB2NDSTR
; patient info;input:Y(0);output:FBDOB,FBFI,FBFLNAM,FBLNAM,FBMI,FBNAME,FBSEX,FBSSN
D PAT^FBAAUTL2
S DFN=$P(FB0,U)
S FBFLNAM=$$HL7NAME(DFN),FBFI="",FBMI="" ;name (FBFI,FBMI - obsolete)
; demographic info, output:VADM
D DEM^VADPT Q:$G(VAERR)
S FBBD=$P(VADM(3),"^"),FBBD=$E(FBBD,4,7)_$E(FBBD,2,3) ;DOB
S FBBD=$S(FBBD="":" ",1:FBBD),FBSEX=$P(VADM(5),"^"),FBSEX=$S(FBSEX="F":2,1:1)
S DOD=$P($P(VADM(6),"^"),".") ;DOD
K VADM,VAERR
;S Y(0)=$S($D(^DPT(DFN,.11)):^(.11),1:"") Q:Y(0)']""
;S FBADD=$E($P(Y(0),"^",1),1,21),FBADD=FBADD_$E(PAD,$L(FBADD)+1,21),FBCITY=$E($P(Y(0),"^",4),1,13),FBCITY=FBCITY_$E(PAD,$L(FBCITY)+1,13),FBSTAT=" "
;S STCD=$P(Y(0),"^",5) I STCD]"" S FBSTAT=$S($D(^DIC(5,STCD,0)):$P(^(0),"^",2),1:" ")
;
;address info, output: VAPA()
S VAPA("P")="" D ADD^VADPT Q:$G(VAERR)
S FBADD=$$LRJ($G(VAPA(1)),35)_$$LRJ($G(VAPA(2)),35)_$$LRJ($G(VAPA(3)),35) ;street address
S FBCITY=$$LRJ($G(VAPA(4)),30) ;city
S STCD=+VAPA(5),FBSTAT=$S($D(^DIC(5,STCD,0)):$P(^(0),"^",2),1:" ") ;state FB*3.5*153
S FBZIP=$S('+$G(VAPA(11)):VAPA(6),+VAPA(11):$P(VAPA(11),"^"),1:VAPA(6)) ;zip
;check for Confidential Communication (CC) address
S FBCCFLG=0 I 'VAERR S FBCCFLG=$$SENDCC()
S FB2NDSTR=$$SECLINE()
S FBZIP=$TR(FBZIP,"-","")_$E("000000000",$L(FBZIP)+1,9)
S STCC=+VAPA(7),FBCC="000" I STCC,STCD S FBCC=$S($D(^DIC(5,STCD,1,STCC,0)):$P(^(0),"^",3),1:"000") ;county code
K VAPA,VAERR
;
; eligibility, output:VAEL()
D ELIG^VADPT
S POS=$S(+VAEL(2):+VAEL(2),1:"") ;PERIOD OF SERVICE
K VAEL,VAERR
S POS=$S(POS="":8,$D(^DIC(21,POS,0)):$P(^(0),"^",3),1:8) ;default: 8 (POST-VIETNAM)
S DOD=$S(DOD="":"000000",1:$E(DOD,4,7)_$E(DOD,2,3))
;
; service information
D SVC^VADPT
S POW=$S(+VASV(4):+VASV(4),1:""),POW=$S(POW="":2,POW=1:1,1:2) ;if prisoner of war
;
; remove all variables defined by VADPT
D KVAR^VADPT
;
;using pointer FEE BASIS PATIENT MRA file retrieve info from
;FEE BASIS PATIENT file#161, from its authorization multiple ^FBAAA(DA(1),1,DA
;S FBAUTH=$P(^FBAA(161.26,J,0),"^",3) Q:FBAUTH']"" Q:'$D(^FBAAA(DFN,1,FBAUTH,0)) S Y(0)=^(0) ;Removed line to modify code - FB*3.5*127
S FBAUTH=$P(^FBAA(161.26,J,0),"^",3) I FBAUTH']"" D KILBAD Q ;FB*3.5*153
I '$D(^FBAAA(DFN,1,FBAUTH,0)) D KILBAD Q ;FB*3.5*153
S Y(0)=^(0) ;FB*3.5*127
;authorisation FROM
S FBFR=$P(Y(0),"^")
;authorisation TO
S FBTO=$P(Y(0),"^",2)
;PURPOSE OF VISIT
S POV=$P(Y(0),"^",7),POV=$S(POV="":"",$D(^FBAA(161.82,POV,0)):$P(^(0),"^",3),1:""),POV=$S(POV]"":POV,1:"05")
;TREATMENT TYPE CODE (SHORT TERM,HOME NURSING,I.D. CARD,STATE HOME)
S FBTT=$P(Y(0),"^",13),FBTT=$S(FBTT]"":FBTT,1:1)
;
S FBRECT=$S(FBTT=4:"7",FBTT=2:"S",$G(POV)>28&($G(POV)<50):"C",1:2)
;formatting FORM and TO dates
S FBFR=$E(FBFR,4,7)_$E(FBFR,2,3),FBTO=$E(FBTO,4,7)_$E(FBTO,2,3)
;flag that the authorization From Date is being changed by this
;master record adjustment (see file #161.26, field #5)
I FBTYPE="C" S FBTO=$S(FBFDC=1:" ",1:FBTO)
;
I FBTT=2,"^70^71^74^"'[(U_POV_U) S POV=71
;if
S ZMCNT=ZMCNT+1 I ZMCNT>100 D GETBT,STORE S ZMCNT=ZMCNT+1
; patch FB*3.5*13 changed format of delete MRAs to include the From Date
I FBTYPE="D" D Q
. S FBRECT=$S(FBTT=4:"7",FBTT=2:"S",$G(POV)=31:"C",1:2)
. S FBSTR=FBRECT_FBTYPE_FBSN_FBSSN_FBFR_"$"
. D ZAP
I FBTYPE="R" D
. S FBRECT=$S(FBTT=4:"7",FBTT=2:"S",$G(POV)=31:"C",1:2)
. ; If Re-Instate for a State Home record type then switch to Add
. ; because Central FEE does not retain deleted State Home auth.
. I FBRECT=7 S FBTYPE="A" Q
. ; For all other record types send a Re-Instate followed by a Change
. S FBSTR=FBRECT_FBTYPE_FBSN_FBSSN_"$"
. D ZAP
. S FBTYPE="C"
; construct Add and Change record types
S FBTT=$S(FBMST="Y":0,1:FBTT)
S FBPATICN=$$ICN(DFN) ;get patient's ICN
S FBSTR=FBRECT_FBTYPE_FBSN_FBSSN_FBFI_FBMI_FBFLNAM_FBADD_FBCITY_FBSTAT_FBZIP_FBFR_FBTO_FBCC_FBBD_POV_" "_FBTT_FBSEX_POW_DOD_" "_POS_FBPATICN_"~"
;if no CC address then send only 1st line of Add and Change record
I FBCCFLG=0 S FBSTR=FBSTR_"$" D ZAP Q
;save 1st line of Add and Change record
D STORE
;create 2nd line for CC address
S FBSTR=FB2NDSTR
D ZAP
Q
;place in XMB for transmission and update FBAA(161.26
ZAP D STORE
S DA=J,(DIC,DIE)="^FBAA(161.26,",T="T",DR="1///^S X=T;4///^S X=DT" D ^DIE
Q
SKIP S FBRECT=$S(FBTT=2:"S",1:2),FBSTR=FBRECT_FBTYPE_FBSN_FBSSN_"$" G ZAP
STORE I ZMCNT>100 D XMIT^FBAAV01,NEWMSG^FBAAV01 S ZMCNT=1
D STORE^FBAAV01
Q
;---
;Patient's INTEGRATION CONTROL NUMBER
;to be implemented in future
;meanwhile returns 17 spaces
ICN(FBDFN) ;
Q $$LRJ("",17)
;---
;adds spaces on right/left or truncates to make return string FBLEN characters long
;FBST- original string
;FBLEN - desired length
;FBCHR -character (default = SPACE)
;FBSIDE - on which side to add characters (default = RIGHT)
LRJ(FBST,FBLEN,FBCHR,FBSIDE) ;
N Y S $P(Y,$S($L($G(FBCHR)):FBCHR,1:" "),$S(FBLEN-$L(FBST)<0:1,1:FBLEN-$L(FBST)+1))=""
Q $E($S($G(FBSIDE)="L":Y_FBST,1:FBST_Y),1,FBLEN)
;---
;parse name components
HL7NAME(FBDFN) ;
N FBAR,FBNM
S FBAR("FILE")=2,FBAR("IENS")=FBDFN,FBAR("FIELD")=.01
S FBNM=$$HLNAME^XLFNAME(.FBAR,"L30","|")
Q $$LRJ(FBNM,30)
;
;create 2nd line for CC address
;VAPA should be determined
SECLINE() ;
N FBSTR1
S FBSTR1=$$LRJ($G(VAPA(13)),35)_$$LRJ($G(VAPA(14)),35)_$$LRJ($G(VAPA(15)),35)_$$LRJ($G(VAPA(16)),30) ;street address
S FBSTR1=FBSTR1_$$LRJ($S(+$G(VAPA(17)):$P($G(^DIC(5,+$G(VAPA(17)),0)),"^",2),1:""),2) ;state
S FBSTR1=FBSTR1_$$LRJ($TR($P($G(VAPA(18)),"^",1),"-",""),9,"0") ;zip
S FBSTR1=FBSTR1_$$LRJ($E(+$G(VAPA(20)),4,5)_$E(+$G(VAPA(20)),6,7)_$E(+$G(VAPA(20)),2,3),6)
S FBSTR1=FBSTR1_$$LRJ($E(+$G(VAPA(21)),4,5)_$E(+$G(VAPA(21)),6,7)_$E(+$G(VAPA(21)),2,3),6)
S FBSTR1=FBSTR1_$$LRJ($P($G(^DIC(5,+$G(VAPA(17)),1,+$G(VAPA(19)),0)),"^",3),3,"0","L") ;county code
S FBSTR1=FBSTR1_"~$"
Q FBSTR1
;------
;SENDCC
;returns 1 if CC address needs to be sent, otherwise - 0
;is called after ADD^VADPT, i.e. VAPA should be defined
SENDCC() ;
;if it is currrently active
I $$ACTIVECC^FBAACO0() Q 1
N X D NOW^%DTC ;set X to TODAY
I ($P($G(VAPA(22,3)),"^",3)="Y"),+$G(VAPA(20))>X Q 1
Q 0
;
KILBAD ;DELETE mra W/ NO POINTER OR UNDEFINED POINTER TO PAT. AUTH
I $D(DA) S FBHDA=DA
S DA=J,DIK="^FBAA(161.26," D ^DIK K DIK
I $D(FBHDA) S DA=FBHDA K FBHDA
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAV4 8145 printed Sep 23, 2025@19:33:03 Page 2
FBAAV4 ;AISC/GRR-ELECTRONICALLY TRANSMIT PATIENT MRA'S ;12/16/2003
+1 ;;3.5;FEE BASIS;**13,34,37,70,146,127,153,158**;JAN 30, 1995;Build 94
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;FB*3.5*153 Modify MRA transmission to Austin to insure that a
+5 ; undefined state code defaults to 2 spaces.
+6 ; Also, delete the entry in file 161.26 if no auth
+7 ; pointer exists in record or the auth pointer points
+8 ; to deleted patient authorization. In addition,
+9 ; insure processing continues if error condition
+10 ; and less than 100 stacked msgs for transmission.
+11 ;
+12 ;D STATION^FBAAUTL,HD^FBAAUTL Q:$D(FB("ERROR"))
+13 ;FBTXT , ZMCNT
SET FBTXT=0
SET ZMCNT=1
GO SET J=0
FOR
SET J=$ORDER(^FBAA(161.26,"AC","P",J))
if J'>0
QUIT
SET FB0=$GET(^FBAA(161.26,J,0))
IF $PIECE(FB0,U)
SET Y(0)=$GET(^DPT($PIECE(FB0,U),0))
IF Y(0)]""
SET FBTYPE=$SELECT($PIECE(FB0,U,4)]"":$PIECE(FB0,U,4),1:"A")
SET FBFDC=$PIECE(FB0,U,6)
SET FBMST=$PIECE(FB0,U,7)
Begin DoDot:1
+1 ; GETBT-prepare header
+2 ; NEWMSG^FBAAV01-get new message number, reset line counter, set subject line
+3 ; STORE^FBAAV01- increment line counter and store in ^XMB
+4 ; FBLN -line counter; FBFEE- "FEE message" counter; FBOKTX=1 if message pending, 0 otherwise
+5 IF 'FBTXT
SET FBTXT=1
DO GETBT
DO NEWMSG^FBAAV01
DO STORE^FBAAV01
+6 ; prepare and store patient MRA portion (can be more than 1)
+7 DO GOT
End DoDot:1
+8 ;FB*3.5*153
if ZMCNT>1
DO XMIT^FBAAV01
+9 QUIT
+10 ;GETBT - prepare the "header" of the message
GETBT ;get next batch # in FBBN
DO GETNXB^FBAAUTL
+1 ;FB*3.5*158
SET FBZBN=$EXTRACT("0000000",$LENGTH(FBBN)+1,7)_FBBN
+2 SET FBSN=FBSN_$EXTRACT(" ",$LENGTH(FBSN)+1,6)
+3 SET FBSTR=FBHD_"C2"_$EXTRACT(DT,4,7)_$EXTRACT(DT,2,3)_FBSN_FBZBN_"$"
+4 QUIT
+5 ;
GOT ;patient MRA portion of the message
+1 NEW FBCCFLG,FBPATICN,FB2NDSTR
+2 ; patient info;input:Y(0);output:FBDOB,FBFI,FBFLNAM,FBLNAM,FBMI,FBNAME,FBSEX,FBSSN
+3 DO PAT^FBAAUTL2
+4 SET DFN=$PIECE(FB0,U)
+5 ;name (FBFI,FBMI - obsolete)
SET FBFLNAM=$$HL7NAME(DFN)
SET FBFI=""
SET FBMI=""
+6 ; demographic info, output:VADM
+7 DO DEM^VADPT
if $GET(VAERR)
QUIT
+8 ;DOB
SET FBBD=$PIECE(VADM(3),"^")
SET FBBD=$EXTRACT(FBBD,4,7)_$EXTRACT(FBBD,2,3)
+9 SET FBBD=$SELECT(FBBD="":" ",1:FBBD)
SET FBSEX=$PIECE(VADM(5),"^")
SET FBSEX=$SELECT(FBSEX="F":2,1:1)
+10 ;DOD
SET DOD=$PIECE($PIECE(VADM(6),"^"),".")
+11 KILL VADM,VAERR
+12 ;S Y(0)=$S($D(^DPT(DFN,.11)):^(.11),1:"") Q:Y(0)']""
+13 ;S FBADD=$E($P(Y(0),"^",1),1,21),FBADD=FBADD_$E(PAD,$L(FBADD)+1,21),FBCITY=$E($P(Y(0),"^",4),1,13),FBCITY=FBCITY_$E(PAD,$L(FBCITY)+1,13),FBSTAT=" "
+14 ;S STCD=$P(Y(0),"^",5) I STCD]"" S FBSTAT=$S($D(^DIC(5,STCD,0)):$P(^(0),"^",2),1:" ")
+15 ;
+16 ;address info, output: VAPA()
+17 SET VAPA("P")=""
DO ADD^VADPT
if $GET(VAERR)
QUIT
+18 ;street address
SET FBADD=$$LRJ($GET(VAPA(1)),35)_$$LRJ($GET(VAPA(2)),35)_$$LRJ($GET(VAPA(3)),35)
+19 ;city
SET FBCITY=$$LRJ($GET(VAPA(4)),30)
+20 ;state FB*3.5*153
SET STCD=+VAPA(5)
SET FBSTAT=$SELECT($DATA(^DIC(5,STCD,0)):$PIECE(^(0),"^",2),1:" ")
+21 ;zip
SET FBZIP=$SELECT('+$GET(VAPA(11)):VAPA(6),+VAPA(11):$PIECE(VAPA(11),"^"),1:VAPA(6))
+22 ;check for Confidential Communication (CC) address
+23 SET FBCCFLG=0
IF 'VAERR
SET FBCCFLG=$$SENDCC()
+24 SET FB2NDSTR=$$SECLINE()
+25 SET FBZIP=$TRANSLATE(FBZIP,"-","")_$EXTRACT("000000000",$LENGTH(FBZIP)+1,9)
+26 ;county code
SET STCC=+VAPA(7)
SET FBCC="000"
IF STCC
IF STCD
SET FBCC=$SELECT($DATA(^DIC(5,STCD,1,STCC,0)):$PIECE(^(0),"^",3),1:"000")
+27 KILL VAPA,VAERR
+28 ;
+29 ; eligibility, output:VAEL()
+30 DO ELIG^VADPT
+31 ;PERIOD OF SERVICE
SET POS=$SELECT(+VAEL(2):+VAEL(2),1:"")
+32 KILL VAEL,VAERR
+33 ;default: 8 (POST-VIETNAM)
SET POS=$SELECT(POS="":8,$DATA(^DIC(21,POS,0)):$PIECE(^(0),"^",3),1:8)
+34 SET DOD=$SELECT(DOD="":"000000",1:$EXTRACT(DOD,4,7)_$EXTRACT(DOD,2,3))
+35 ;
+36 ; service information
+37 DO SVC^VADPT
+38 ;if prisoner of war
SET POW=$SELECT(+VASV(4):+VASV(4),1:"")
SET POW=$SELECT(POW="":2,POW=1:1,1:2)
+39 ;
+40 ; remove all variables defined by VADPT
+41 DO KVAR^VADPT
+42 ;
+43 ;using pointer FEE BASIS PATIENT MRA file retrieve info from
+44 ;FEE BASIS PATIENT file#161, from its authorization multiple ^FBAAA(DA(1),1,DA
+45 ;S FBAUTH=$P(^FBAA(161.26,J,0),"^",3) Q:FBAUTH']"" Q:'$D(^FBAAA(DFN,1,FBAUTH,0)) S Y(0)=^(0) ;Removed line to modify code - FB*3.5*127
+46 ;FB*3.5*153
SET FBAUTH=$PIECE(^FBAA(161.26,J,0),"^",3)
IF FBAUTH']""
DO KILBAD
QUIT
+47 ;FB*3.5*153
IF '$DATA(^FBAAA(DFN,1,FBAUTH,0))
DO KILBAD
QUIT
+48 ;FB*3.5*127
SET Y(0)=^(0)
+49 ;authorisation FROM
+50 SET FBFR=$PIECE(Y(0),"^")
+51 ;authorisation TO
+52 SET FBTO=$PIECE(Y(0),"^",2)
+53 ;PURPOSE OF VISIT
+54 SET POV=$PIECE(Y(0),"^",7)
SET POV=$SELECT(POV="":"",$DATA(^FBAA(161.82,POV,0)):$PIECE(^(0),"^",3),1:"")
SET POV=$SELECT(POV]"":POV,1:"05")
+55 ;TREATMENT TYPE CODE (SHORT TERM,HOME NURSING,I.D. CARD,STATE HOME)
+56 SET FBTT=$PIECE(Y(0),"^",13)
SET FBTT=$SELECT(FBTT]"":FBTT,1:1)
+57 ;
+58 SET FBRECT=$SELECT(FBTT=4:"7",FBTT=2:"S",$GET(POV)>28&($GET(POV)<50):"C",1:2)
+59 ;formatting FORM and TO dates
+60 SET FBFR=$EXTRACT(FBFR,4,7)_$EXTRACT(FBFR,2,3)
SET FBTO=$EXTRACT(FBTO,4,7)_$EXTRACT(FBTO,2,3)
+61 ;flag that the authorization From Date is being changed by this
+62 ;master record adjustment (see file #161.26, field #5)
+63 IF FBTYPE="C"
SET FBTO=$SELECT(FBFDC=1:" ",1:FBTO)
+64 ;
+65 IF FBTT=2
IF "^70^71^74^"'[(U_POV_U)
SET POV=71
+66 ;if
+67 SET ZMCNT=ZMCNT+1
IF ZMCNT>100
DO GETBT
DO STORE
SET ZMCNT=ZMCNT+1
+68 ; patch FB*3.5*13 changed format of delete MRAs to include the From Date
+69 IF FBTYPE="D"
Begin DoDot:1
+70 SET FBRECT=$SELECT(FBTT=4:"7",FBTT=2:"S",$GET(POV)=31:"C",1:2)
+71 SET FBSTR=FBRECT_FBTYPE_FBSN_FBSSN_FBFR_"$"
+72 DO ZAP
End DoDot:1
QUIT
+73 IF FBTYPE="R"
Begin DoDot:1
+74 SET FBRECT=$SELECT(FBTT=4:"7",FBTT=2:"S",$GET(POV)=31:"C",1:2)
+75 ; If Re-Instate for a State Home record type then switch to Add
+76 ; because Central FEE does not retain deleted State Home auth.
+77 IF FBRECT=7
SET FBTYPE="A"
QUIT
+78 ; For all other record types send a Re-Instate followed by a Change
+79 SET FBSTR=FBRECT_FBTYPE_FBSN_FBSSN_"$"
+80 DO ZAP
+81 SET FBTYPE="C"
End DoDot:1
+82 ; construct Add and Change record types
+83 SET FBTT=$SELECT(FBMST="Y":0,1:FBTT)
+84 ;get patient's ICN
SET FBPATICN=$$ICN(DFN)
+85 SET FBSTR=FBRECT_FBTYPE_FBSN_FBSSN_FBFI_FBMI_FBFLNAM_FBADD_FBCITY_FBSTAT_FBZIP_FBFR_FBTO_FBCC_FBBD_POV_" "_FBTT_FBSEX_POW_DOD_" "_POS_FBPATICN_"~"
+86 ;if no CC address then send only 1st line of Add and Change record
+87 IF FBCCFLG=0
SET FBSTR=FBSTR_"$"
DO ZAP
QUIT
+88 ;save 1st line of Add and Change record
+89 DO STORE
+90 ;create 2nd line for CC address
+91 SET FBSTR=FB2NDSTR
+92 DO ZAP
+93 QUIT
+94 ;place in XMB for transmission and update FBAA(161.26
ZAP DO STORE
+1 SET DA=J
SET (DIC,DIE)="^FBAA(161.26,"
SET T="T"
SET DR="1///^S X=T;4///^S X=DT"
DO ^DIE
+2 QUIT
SKIP SET FBRECT=$SELECT(FBTT=2:"S",1:2)
SET FBSTR=FBRECT_FBTYPE_FBSN_FBSSN_"$"
GOTO ZAP
STORE IF ZMCNT>100
DO XMIT^FBAAV01
DO NEWMSG^FBAAV01
SET ZMCNT=1
+1 DO STORE^FBAAV01
+2 QUIT
+3 ;---
+4 ;Patient's INTEGRATION CONTROL NUMBER
+5 ;to be implemented in future
+6 ;meanwhile returns 17 spaces
ICN(FBDFN) ;
+1 QUIT $$LRJ("",17)
+2 ;---
+3 ;adds spaces on right/left or truncates to make return string FBLEN characters long
+4 ;FBST- original string
+5 ;FBLEN - desired length
+6 ;FBCHR -character (default = SPACE)
+7 ;FBSIDE - on which side to add characters (default = RIGHT)
LRJ(FBST,FBLEN,FBCHR,FBSIDE) ;
+1 NEW Y
SET $PIECE(Y,$SELECT($LENGTH($GET(FBCHR)):FBCHR,1:" "),$SELECT(FBLEN-$LENGTH(FBST)<0:1,1:FBLEN-$LENGTH(FBST)+1))=""
+2 QUIT $EXTRACT($SELECT($GET(FBSIDE)="L":Y_FBST,1:FBST_Y),1,FBLEN)
+3 ;---
+4 ;parse name components
HL7NAME(FBDFN) ;
+1 NEW FBAR,FBNM
+2 SET FBAR("FILE")=2
SET FBAR("IENS")=FBDFN
SET FBAR("FIELD")=.01
+3 SET FBNM=$$HLNAME^XLFNAME(.FBAR,"L30","|")
+4 QUIT $$LRJ(FBNM,30)
+5 ;
+6 ;create 2nd line for CC address
+7 ;VAPA should be determined
SECLINE() ;
+1 NEW FBSTR1
+2 ;street address
SET FBSTR1=$$LRJ($GET(VAPA(13)),35)_$$LRJ($GET(VAPA(14)),35)_$$LRJ($GET(VAPA(15)),35)_$$LRJ($GET(VAPA(16)),30)
+3 ;state
SET FBSTR1=FBSTR1_$$LRJ($SELECT(+$GET(VAPA(17)):$PIECE($GET(^DIC(5,+$GET(VAPA(17)),0)),"^",2),1:""),2)
+4 ;zip
SET FBSTR1=FBSTR1_$$LRJ($TRANSLATE($PIECE($GET(VAPA(18)),"^",1),"-",""),9,"0")
+5 SET FBSTR1=FBSTR1_$$LRJ($EXTRACT(+$GET(VAPA(20)),4,5)_$EXTRACT(+$GET(VAPA(20)),6,7)_$EXTRACT(+$GET(VAPA(20)),2,3),6)
+6 SET FBSTR1=FBSTR1_$$LRJ($EXTRACT(+$GET(VAPA(21)),4,5)_$EXTRACT(+$GET(VAPA(21)),6,7)_$EXTRACT(+$GET(VAPA(21)),2,3),6)
+7 ;county code
SET FBSTR1=FBSTR1_$$LRJ($PIECE($GET(^DIC(5,+$GET(VAPA(17)),1,+$GET(VAPA(19)),0)),"^",3),3,"0","L")
+8 SET FBSTR1=FBSTR1_"~$"
+9 QUIT FBSTR1
+10 ;------
+11 ;SENDCC
+12 ;returns 1 if CC address needs to be sent, otherwise - 0
+13 ;is called after ADD^VADPT, i.e. VAPA should be defined
SENDCC() ;
+1 ;if it is currrently active
+2 IF $$ACTIVECC^FBAACO0()
QUIT 1
+3 ;set X to TODAY
NEW X
DO NOW^%DTC
+4 IF ($PIECE($GET(VAPA(22,3)),"^",3)="Y")
IF +$GET(VAPA(20))>X
QUIT 1
+5 QUIT 0
+6 ;
KILBAD ;DELETE mra W/ NO POINTER OR UNDEFINED POINTER TO PAT. AUTH
+1 IF $DATA(DA)
SET FBHDA=DA
+2 SET DA=J
SET DIK="^FBAA(161.26,"
DO ^DIK
KILL DIK
+3 IF $DATA(FBHDA)
SET DA=FBHDA
KILL FBHDA
+4 QUIT
