- 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 Feb 18, 2025@23:23:24 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