| 1 | FBAAV4 ;AISC/GRR-ELECTRONICALLY TRANSMIT PATIENT MRA'S ;12/16/2003
|
|---|
| 2 | ;;3.5;FEE BASIS;**13,34,37,70**;JAN 30, 1995
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;D STATION^FBAAUTL,HD^FBAAUTL Q:$D(FB("ERROR"))
|
|---|
| 5 | S FBTXT=0,ZMCNT=1 ;FBTXT , ZMCNT
|
|---|
| 6 | 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
|
|---|
| 7 | .; GETBT-prepare header
|
|---|
| 8 | .; NEWMSG^FBAAV01-get new message number, reset line counter, set subject line
|
|---|
| 9 | .; STORE^FBAAV01- increment line counter and store in ^XMB
|
|---|
| 10 | .; FBLN -line counter; FBFEE- "FEE message" counter; FBOKTX=1 if message pending, 0 otherwise
|
|---|
| 11 | .I 'FBTXT S FBTXT=1 D GETBT,NEWMSG^FBAAV01,STORE^FBAAV01
|
|---|
| 12 | .; prepare and store patient MRA portion (can be more than 1)
|
|---|
| 13 | .D GOT
|
|---|
| 14 | D:+$G(FBOKTX) XMIT^FBAAV01
|
|---|
| 15 | Q
|
|---|
| 16 | ;GETBT - prepare the "header" of the message
|
|---|
| 17 | GETBT D GETNXB^FBAAUTL ;get next batch # in FBBN
|
|---|
| 18 | S FBZBN=$E("00000",$L(FBBN)+1,5)_FBBN,FBSN=FBSN_$E(" ",$L(FBSN)+1,6)
|
|---|
| 19 | S FBSTR=FBHD_"C2"_$E(DT,4,7)_$E(DT,2,3)_FBSN_FBZBN_"$"
|
|---|
| 20 | Q
|
|---|
| 21 | ;
|
|---|
| 22 | GOT ;patient MRA portion of the message
|
|---|
| 23 | N FBCCFLG,FBPATICN,FB2NDSTR
|
|---|
| 24 | ; patient info;input:Y(0);output:FBDOB,FBFI,FBFLNAM,FBLNAM,FBMI,FBNAME,FBSEX,FBSSN
|
|---|
| 25 | D PAT^FBAAUTL2
|
|---|
| 26 | S DFN=$P(FB0,U)
|
|---|
| 27 | S FBFLNAM=$$HL7NAME(DFN),FBFI="",FBMI="" ;name (FBFI,FBMI - obsolete)
|
|---|
| 28 | ; demographic info, output:VADM
|
|---|
| 29 | D DEM^VADPT Q:$G(VAERR)
|
|---|
| 30 | S FBBD=$P(VADM(3),"^"),FBBD=$E(FBBD,4,7)_$E(FBBD,2,3) ;DOB
|
|---|
| 31 | S FBBD=$S(FBBD="":" ",1:FBBD),FBSEX=$P(VADM(5),"^"),FBSEX=$S(FBSEX="F":2,1:1)
|
|---|
| 32 | S DOD=$P($P(VADM(6),"^"),".") ;DOD
|
|---|
| 33 | K VADM,VAERR
|
|---|
| 34 | ;S Y(0)=$S($D(^DPT(DFN,.11)):^(.11),1:"") Q:Y(0)']""
|
|---|
| 35 | ;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=" "
|
|---|
| 36 | ;S STCD=$P(Y(0),"^",5) I STCD]"" S FBSTAT=$S($D(^DIC(5,STCD,0)):$P(^(0),"^",2),1:" ")
|
|---|
| 37 | ;
|
|---|
| 38 | ;address info, output: VAPA()
|
|---|
| 39 | S VAPA("P")="" D ADD^VADPT Q:$G(VAERR)
|
|---|
| 40 | S FBADD=$$LRJ($G(VAPA(1)),35)_$$LRJ($G(VAPA(2)),35)_$$LRJ($G(VAPA(3)),35) ;street address
|
|---|
| 41 | S FBCITY=$$LRJ($G(VAPA(4)),30) ;city
|
|---|
| 42 | S STCD=+VAPA(5) I STCD S FBSTAT=$S($D(^DIC(5,STCD,0)):$P(^(0),"^",2),1:" ") ;state
|
|---|
| 43 | S FBZIP=$S('+$G(VAPA(11)):VAPA(6),+VAPA(11):$P(VAPA(11),"^"),1:VAPA(6)) ;zip
|
|---|
| 44 | ;check for Confidential Communication (CC) address
|
|---|
| 45 | S FBCCFLG=0 I 'VAERR S FBCCFLG=$$SENDCC()
|
|---|
| 46 | S FB2NDSTR=$$SECLINE()
|
|---|
| 47 | S FBZIP=$TR(FBZIP,"-","")_$E("000000000",$L(FBZIP)+1,9)
|
|---|
| 48 | 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
|
|---|
| 49 | K VAPA,VAERR
|
|---|
| 50 | ;
|
|---|
| 51 | ; eligibility, output:VAEL()
|
|---|
| 52 | D ELIG^VADPT
|
|---|
| 53 | S POS=$S(+VAEL(2):+VAEL(2),1:"") ;PERIOD OF SERVICE
|
|---|
| 54 | K VAEL,VAERR
|
|---|
| 55 | S POS=$S(POS="":8,$D(^DIC(21,POS,0)):$P(^(0),"^",3),1:8) ;default: 8 (POST-VIETNAM)
|
|---|
| 56 | S DOD=$S(DOD="":"000000",1:$E(DOD,4,7)_$E(DOD,2,3))
|
|---|
| 57 | ;
|
|---|
| 58 | ; service information
|
|---|
| 59 | D SVC^VADPT
|
|---|
| 60 | S POW=$S(+VASV(4):+VASV(4),1:""),POW=$S(POW="":2,POW=1:1,1:2) ;if prisoner of war
|
|---|
| 61 | ;
|
|---|
| 62 | ; remove all variables defined by VADPT
|
|---|
| 63 | D KVAR^VADPT
|
|---|
| 64 | ;
|
|---|
| 65 | ;using pointer FEE BASIS PATIENT MRA file retrieve info from
|
|---|
| 66 | ;FEE BASIS PATIENT file#161, from its authorization multiple ^FBAAA(DA(1),1,DA
|
|---|
| 67 | S FBAUTH=$P(^FBAA(161.26,J,0),"^",3) Q:FBAUTH']"" Q:'$D(^FBAAA(DFN,1,FBAUTH,0)) S Y(0)=^(0)
|
|---|
| 68 | ;authorisation FROM
|
|---|
| 69 | S FBFR=$P(Y(0),"^")
|
|---|
| 70 | ;authorisation TO
|
|---|
| 71 | S FBTO=$P(Y(0),"^",2)
|
|---|
| 72 | ;PURPOSE OF VISIT
|
|---|
| 73 | 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")
|
|---|
| 74 | ;TREATMENT TYPE CODE (SHORT TERM,HOME NURSING,I.D. CARD,STATE HOME)
|
|---|
| 75 | S FBTT=$P(Y(0),"^",13),FBTT=$S(FBTT]"":FBTT,1:1)
|
|---|
| 76 | ;
|
|---|
| 77 | S FBRECT=$S(FBTT=4:"7",FBTT=2:"S",$G(POV)>29&($G(POV)<50):"C",1:2)
|
|---|
| 78 | ;formatting FORM and TO dates
|
|---|
| 79 | S FBFR=$E(FBFR,4,7)_$E(FBFR,2,3),FBTO=$E(FBTO,4,7)_$E(FBTO,2,3)
|
|---|
| 80 | ;flag that the authorization From Date is being changed by this
|
|---|
| 81 | ;master record adjustment (see file #161.26, field #5)
|
|---|
| 82 | I FBTYPE="C" S FBTO=$S(FBFDC=1:" ",1:FBTO)
|
|---|
| 83 | ;
|
|---|
| 84 | I FBTT=2,"^70^71^74^"'[(U_POV_U) S POV=71
|
|---|
| 85 | ;if
|
|---|
| 86 | S ZMCNT=ZMCNT+1 I ZMCNT>100 D GETBT,STORE S ZMCNT=ZMCNT+1
|
|---|
| 87 | ; patch FB*3.5*13 changed format of delete MRAs to include the From Date
|
|---|
| 88 | I FBTYPE="D" D Q
|
|---|
| 89 | . S FBRECT=$S(FBTT=4:"7",FBTT=2:"S",$G(POV)=31:"C",1:2)
|
|---|
| 90 | . S FBSTR=FBRECT_FBTYPE_FBSN_FBSSN_FBFR_"$"
|
|---|
| 91 | . D ZAP
|
|---|
| 92 | I FBTYPE="R" D
|
|---|
| 93 | . S FBRECT=$S(FBTT=4:"7",FBTT=2:"S",$G(POV)=31:"C",1:2)
|
|---|
| 94 | . ; If Re-Instate for a State Home record type then switch to Add
|
|---|
| 95 | . ; because Central FEE does not retain deleted State Home auth.
|
|---|
| 96 | . I FBRECT=7 S FBTYPE="A" Q
|
|---|
| 97 | . ; For all other record types send a Re-Instate followed by a Change
|
|---|
| 98 | . S FBSTR=FBRECT_FBTYPE_FBSN_FBSSN_"$"
|
|---|
| 99 | . D ZAP
|
|---|
| 100 | . S FBTYPE="C"
|
|---|
| 101 | ; construct Add and Change record types
|
|---|
| 102 | S FBTT=$S(FBMST="Y":0,1:FBTT)
|
|---|
| 103 | S FBPATICN=$$ICN(DFN) ;get patient's ICN
|
|---|
| 104 | S FBSTR=FBRECT_FBTYPE_FBSN_FBSSN_FBFI_FBMI_FBFLNAM_FBADD_FBCITY_FBSTAT_FBZIP_FBFR_FBTO_FBCC_FBBD_POV_" "_FBTT_FBSEX_POW_DOD_" "_POS_FBPATICN_"~"
|
|---|
| 105 | ;if no CC address then send only 1st line of Add and Change record
|
|---|
| 106 | I FBCCFLG=0 S FBSTR=FBSTR_"$" D ZAP Q
|
|---|
| 107 | ;save 1st line of Add and Change record
|
|---|
| 108 | D STORE
|
|---|
| 109 | ;create 2nd line for CC address
|
|---|
| 110 | S FBSTR=FB2NDSTR
|
|---|
| 111 | D ZAP
|
|---|
| 112 | Q
|
|---|
| 113 | ;place in XMB for transmission and update FBAA(161.26
|
|---|
| 114 | ZAP D STORE
|
|---|
| 115 | S DA=J,(DIC,DIE)="^FBAA(161.26,",T="T",DR="1///^S X=T;4///^S X=DT" D ^DIE
|
|---|
| 116 | Q
|
|---|
| 117 | SKIP S FBRECT=$S(FBTT=2:"S",1:2),FBSTR=FBRECT_FBTYPE_FBSN_FBSSN_"$" G ZAP
|
|---|
| 118 | STORE I ZMCNT>100 D XMIT^FBAAV01,NEWMSG^FBAAV01 S ZMCNT=1
|
|---|
| 119 | D STORE^FBAAV01
|
|---|
| 120 | Q
|
|---|
| 121 | ;---
|
|---|
| 122 | ;Patient's INTEGRATION CONTROL NUMBER
|
|---|
| 123 | ;to be implemented in future
|
|---|
| 124 | ;meanwhile returns 17 spaces
|
|---|
| 125 | ICN(FBDFN) ;
|
|---|
| 126 | Q $$LRJ("",17)
|
|---|
| 127 | ;---
|
|---|
| 128 | ;adds spaces on right/left or truncates to make return string FBLEN characters long
|
|---|
| 129 | ;FBST- original string
|
|---|
| 130 | ;FBLEN - desired length
|
|---|
| 131 | ;FBCHR -character (default = SPACE)
|
|---|
| 132 | ;FBSIDE - on which side to add characters (default = RIGHT)
|
|---|
| 133 | LRJ(FBST,FBLEN,FBCHR,FBSIDE) ;
|
|---|
| 134 | N Y S $P(Y,$S($L($G(FBCHR)):FBCHR,1:" "),$S(FBLEN-$L(FBST)<0:1,1:FBLEN-$L(FBST)+1))=""
|
|---|
| 135 | Q $E($S($G(FBSIDE)="L":Y_FBST,1:FBST_Y),1,FBLEN)
|
|---|
| 136 | ;---
|
|---|
| 137 | ;parse name components
|
|---|
| 138 | HL7NAME(FBDFN) ;
|
|---|
| 139 | N FBAR,FBNM
|
|---|
| 140 | S FBAR("FILE")=2,FBAR("IENS")=FBDFN,FBAR("FIELD")=.01
|
|---|
| 141 | S FBNM=$$HLNAME^XLFNAME(.FBAR,"L30","|")
|
|---|
| 142 | Q $$LRJ(FBNM,30)
|
|---|
| 143 | ;
|
|---|
| 144 | ;create 2nd line for CC address
|
|---|
| 145 | ;VAPA should be determined
|
|---|
| 146 | SECLINE() ;
|
|---|
| 147 | N FBSTR1
|
|---|
| 148 | S FBSTR1=$$LRJ($G(VAPA(13)),35)_$$LRJ($G(VAPA(14)),35)_$$LRJ($G(VAPA(15)),35)_$$LRJ($G(VAPA(16)),30) ;street address
|
|---|
| 149 | S FBSTR1=FBSTR1_$$LRJ($S(+$G(VAPA(17)):$P($G(^DIC(5,+$G(VAPA(17)),0)),"^",2),1:""),2) ;state
|
|---|
| 150 | S FBSTR1=FBSTR1_$$LRJ($TR($P($G(VAPA(18)),"^",1),"-",""),9,"0") ;zip
|
|---|
| 151 | S FBSTR1=FBSTR1_$$LRJ($E(+$G(VAPA(20)),4,5)_$E(+$G(VAPA(20)),6,7)_$E(+$G(VAPA(20)),2,3),6)
|
|---|
| 152 | S FBSTR1=FBSTR1_$$LRJ($E(+$G(VAPA(21)),4,5)_$E(+$G(VAPA(21)),6,7)_$E(+$G(VAPA(21)),2,3),6)
|
|---|
| 153 | S FBSTR1=FBSTR1_$$LRJ($P($G(^DIC(5,+$G(VAPA(17)),1,+$G(VAPA(19)),0)),"^",3),3,"0","L") ;county code
|
|---|
| 154 | S FBSTR1=FBSTR1_"~$"
|
|---|
| 155 | Q FBSTR1
|
|---|
| 156 | ;------
|
|---|
| 157 | ;SENDCC
|
|---|
| 158 | ;returns 1 if CC address needs to be sent, otherwise - 0
|
|---|
| 159 | ;is called after ADD^VADPT, i.e. VAPA should be defined
|
|---|
| 160 | SENDCC() ;
|
|---|
| 161 | ;if it is currrently active
|
|---|
| 162 | I $$ACTIVECC^FBAACO0() Q 1
|
|---|
| 163 | N X D NOW^%DTC ;set X to TODAY
|
|---|
| 164 | I ($P($G(VAPA(22,3)),"^",3)="Y"),+$G(VAPA(20))>X Q 1
|
|---|
| 165 | Q 0
|
|---|
| 166 | ;
|
|---|
