source: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBMRASVR.m@ 1789

Last change on this file since 1789 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 6.0 KB
Line 
1FBMRASVR ;AISC/CMR-Server Routine for MRA Messages ;11 Apr 2006 2:50 PM
2 ;;3.5;FEE BASIS;**9,39,50,97,98**;JAN 30, 1995;Build 54
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 S X="TRAP^FBMRASV2" S @^%ZOSF("TRAP")
5 ;K XMY S XMY("G.FEE DEVELOPERS@ISC-ALBANY.VA.GOV")="" D ENT1^XMD
6 K ^TMP("FBMRA",$J),^TMP("FBER",$J)
7 F I=1:1 X XMREC Q:XMER<0 S:$S($E(XMRG,1)=1:1,$E(XMRG,1)=4:1,1:0)&($S($E(XMRG,2)="C":1,$E(XMRG,2)="A":1,$E(XMRG,2)="Q":1,$E(XMRG,2)="F":1,1:0)) ^TMP("FBMRA",$J,I)=XMRG
8TEST S (FBCNT,FBATOT,FBCTOT,FBFTOT,FBQTOT,FBI,FBID,FBER)=0 D STATION^FBAAUTL
9 F S FBI=$O(^TMP("FBMRA",$J,FBI)) Q:'FBI S FBERR=0,FBJ=^(FBI),FBRT=$E(FBJ,1),FBAC=$E(FBJ,2) D PARSE D
10 .I 'FBERR D EXTRACT S FBID=$$CKID(FBVID) S FBERR=$S('FBID:1,1:0) D:'FBERR ADD:FBAC="A"!(FBAC="Q"),CHANGE^FBMRASV1:FBAC="C",FPDS:FBAC="F" I FBERR D ER^FBMRASV2(1,FBJ,.FBER)
11 .S:FBAC="A" FBATOT=FBATOT+1 S:FBAC="C" FBCTOT=FBCTOT+1 S:FBAC="Q" FBQTOT=FBQTOT+1 S:FBAC="F" FBFTOT=FBFTOT+1
12 D MSG^FBMRASV2 Q
13PARSE ;Extracts pharmacy or medical mra data
14 D:FBRT=4 ;pharmacy record
15 .I $L(FBJ)=167 S FBJ=$E(FBJ,1,166)_" $"
16 .I $L(FBJ)'=189 D ER^FBMRASV2(2,FBJ,.FBER) S FBERR=1 Q
17 .S FBVID=$E(FBJ,9,17),FBCHAIN=$E(FBJ,18,21),FBFEEO=$E(FBJ,22),FBVNAME=$E(FBJ,23,52),FBADD1=$E(FBJ,53,82),FBADD2=$E(FBJ,83,112),FBCITY=$E(FBJ,113,131),FBST=$E(FBJ,132,133),FBZIP=$E(FBJ,134,142),FBMRC=$E(FBJ,143,144)
18 .S FBCC=$E(FBJ,145,147),FBPC=$E(FBJ,148),FBTID=$E(FBJ,149),FB1099=$E(FBJ,150),FBVT=$E(FBJ,151),FBICN=$E(FBJ,152,166),FBNPI=$E(FBJ,179,188)
19 .S FBBT=$E(FBJ,167,168) F I=1:1:5 S FBSG(I)=$E(FBJ,I*2+167,I*2+168)
20 .S FBCHAIN=$$EXTRL(FBCHAIN,1),FBCHAIN=$S(FBCHAIN=0:"",1:FBCHAIN)
21 D:FBRT=1 ;medical record
22 .I $L(FBJ)=171 S FBJ=$E(FBJ,1,170)_" $"
23 .I $L(FBJ)'=193 D ER^FBMRASV2(2,FBJ,.FBER) S FBERR=1 Q
24 .S FBVID=$E(FBJ,9,19),FBFEEO=$E(FBJ,22),FBSC=$E(FBJ,23,24),FBPART=$E(FBJ,25,26),FBVNAME=$E(FBJ,27,56),FBADD1=$E(FBJ,57,86),FBADD2=$E(FBJ,87,116),FBCITY=$E(FBJ,117,135),FBST=$E(FBJ,136,137),FBZIP=$E(FBJ,138,146),FBNPI=$E(FBJ,183,192)
25 .S FBMRC=$E(FBJ,147,148),FBCC=$E(FBJ,149,151),FBPC=$E(FBJ,152),FBTID=$E(FBJ,153),FB1099=$E(FBJ,154),FBVT=$E(FBJ,155),FBICN=$E(FBJ,156,170)
26 .S FBBT=$E(FBJ,171,172) F I=1:1:5 S FBSG(I)=$E(FBJ,I*2+171,I*2+172)
27 .S FBSC=$S(FBSC=" ":"",$O(^FBAA(161.6,"C",FBSC,0))>0:$O(^FBAA(161.6,"C",FBSC,0)),1:""),FBPART=$$EXTRL(FBPART),FBPART=$O(^FBAA(161.81,"C",+FBPART,0))
28 Q
29EXTRACT ;Calls to remove leading/trailing spaces and zeros
30 D:$D(XRTL) T0^%ZOSV
31 S FBVID=$$EXTRT(FBVID),FBVNAME=$$EXTRT(FBVNAME),FBADD1=$$EXTRT(FBADD1),FBADD2=$$EXTRT(FBADD2),FBCITY=$$EXTRT(FBCITY),FBICN=$$EXTRL(FBICN,1),FBST=$$EXTRT(FBST),FBSTN=$E(FBICN,1,3)
32 S FBMRC=$$EXTRL(FBMRC)
33 S FBBT=$$EXTRT(FBBT)
34 F I=1:1 Q:'$D(FBSG(I)) S FBSG(I)=$$EXTRT(FBSG(I)) I FBSG(I)="" K FBSG(I)
35 ;Conversion from external to internal format.
36 S FBSTATE=$S(FBST']"":"",$D(^DIC(5,"C",FBST)):$O(^DIC(5,"C",FBST,0)),1:""),FBZIP=$S($L(FBZIP)>5:$E(FBZIP,1,5)_"-"_$E(FBZIP,6,$L(FBZIP)),1:FBZIP),FBZIP1=$E(FBZIP,6,9) I '+FBZIP1 S FBZIP=$E(FBZIP,1,5)
37 S FBCC=$S(FBCC=" ":"",FBCC']"":"",FBCC="000":"",$D(^DIC(5,+FBSTATE,1,"C",FBCC)):$O(^(FBCC,0)),1:"") I FBCC']"" S FBCC=$P($G(^FBAAV(+FBICN,0)),"^",13)
38 D:FBAC="Q" EDIT^FBMRASV2
39 S:FBNPI=" " FBNPI=""
40 I $D(XRT0) S XRTN=$T(+0) D T1^%ZOSV
41 Q
42CKID(X) ;determine if 1st 9 char of id is numeric
43 ;INPUT: X = vendor id
44 ;OUTPUT: 1 if ok, 0 if not
45 Q $S('+$G(X):0,X'?9N.2AN:0,1:1) ;$E(X,1,9)?9N:1,1:0)
46 ;
47ADD ;Process Add or Unsolicted Add Record
48 I FBSTN'=FBSN D ER^FBMRASV2(3,FBJ,.FBER) Q
49 D GET D:FBMRA']"" ER^FBMRASV2(5,FBJ,.FBER) I FBMRA]"" S FBCNT=FBCNT+1 D FILEV,DELMRA
50 Q
51FPDS ;Process FPDS-Only or Unsolicated FPDS-Only Record
52 I FBSTN'=FBSN D
53 .N EC S (FBICN,FBOUT)=0,FBERR=1,EC="" D
54 ..F S FBICN=$O(^FBAAV("C",FBVID,FBICN)) Q:'FBICN!(FBOUT) D
55 ...Q:$P($G(^FBAAV(FBICN,"ADEL")),"^")="Y"
56 ...S EC="" I FBRT=4 Q:$P(^FBAAV(FBICN,0),U,7)'=3 Q:$P(^FBAAV(FBICN,0),U,10)'=FBCHAIN
57 ...I FBRT=1 Q:$P($G(^FBAAV(FBICN,0)),U,7)=3
58 ...I $E(FBVNAME,1,5)'=$E($P($G(^FBAAV(FBICN,"AMS")),U),1,5),'+$P($G(^FBAAV(FBICN,"ADEL")),U,4) S EC=4 Q
59 ...S FBCNT=FBCNT+1,FBOUT=1,FBERR=0 D FILEV
60 .I FBERR S:EC']"" EC=4.1 D ER^FBMRASV2(EC,FBJ,.FBER) S FBERR=0
61 Q:FBSTN'=FBSN
62 D GET D:FBMRA']"" ER^FBMRASV2(5,FBJ,.FBER) I FBMRA]"" S FBCNT=FBCNT+1 D FILEV,DELMRA
63 Q
64GET ;Get ICN and MRA entry from MRA file.
65 S FBICN=$E(FBICN,4,$L(FBICN))
66 S FBMRA=$G(^FBAA(161.25,FBICN,0))
67 Q
68FILEV ;Files MRA fm Austin in Vendor file.
69 Q:'$D(^FBAAV(FBICN,0)) N FBNAM S:'FBCC FBCC=$P(^(0),"^",13) S:"ST"'[FBTID FBTID=""
70 I FBAC="C",($G(FBICN1)]""),(FBICN1'=FBICN) S DIK="^FBAAV(",DA=FBICN D ^DIK K DA,DIK S %X="^FBAAV(FBICN1,",%Y="^FBAAV(FBICN," D %XY^%RCR K %X,%Y S DIK="^FBAAV(",DA=FBICN D IX1^DIK K DIK,DA
71 S DIE="^FBAAV(",DA=FBICN
72 S DR="1////^S X=FBVID;2////^S X=FBADD1;2.5////@;2.5////^S X=FBADD2;3////^S X=FBCITY;4////^S X=FBSTATE;5////^S X=FBZIP;5.5////^S X=FBCC;5.18////^S X=FBMRC;"_$S(FBRT=1:".05////^S X=FBSC;7////^S X=FBPART",1:"8////^S X=FBCHAIN")
73 S DR(1,161.2,1)="12.1////^S X=DT;13.1////^S X=$S(FBSTN]"""":FBSTN,1:""000"");30.01////^S X=FBVNAME;30.03////^S X=FB1099;30.04////^S X=FBVT;30.05////^S X=FBPC;30.06////^S X=FBTID"_$S(FBBT]"":";24////^S X=FBBT",1:"")_";41.01////^S X=FBNPI"
74 L +^FBAAV(FBICN):1
75 D ^DIE K DIE,DA,DR
76 I $O(FBSG(0)) D UPDGRP^FBAAUTL6(FBICN)
77 L -^FBAAV(FBICN)
78 Q
79DELMRA ;Deletes MRA entry in FB Vendor Correction File.
80 S FBVIEN=$S(FBAC="C":FBICN1,1:FBICN),DIE="^FBAA(161.25,"
81 I FBAC="C"!(FBAC="Q"),$D(^FBAA(161.25,"AF",FBVIEN)) S FB1=0 F S FB1=$O(^FBAA(161.25,"AF",FBVIEN,FB1)) Q:'FB1 S DA=FB1,FBLDA=$P($G(^FBAA(161.25,FBVIEN,0)),"^",6),DR="5////^S X=FBLDA" D
82 .D LOCK^FBUCUTL(DIE,DA,1) I FBLOCK D ^DIE L -^FBAA(161.25,DA)
83 .K FBLOCK
84 S DA=FBVIEN,DIK="^FBAA(161.25," D ^DIK K DA,DIK,FB1,FBLDA,FBVIEN
85 Q
86EXTRL(V,T) ;Removes leading spaces or zeros.
87 ;V=variable to be parced
88 ;T=1 remove leading zeros, T="" remove leading spaces
89 ;Q VAR
90 S T=$S($D(T):0,1:" ")
91 F Q:$E(V)'=T S V=$E(V,2,$L(V))
92 Q V
93EXTRT(V,T) ;Removes trailing spaces or zeros.
94 ;V=variable to be parced
95 ;T=1 remove trailing zeros, T="" remove trailing spaces
96 N FBL
97 S T=$S($D(T):0,1:" ")
98 F S FBL=$L(V) Q:$E(V,FBL)'=T S V=$E(V,1,FBL-1)
99 Q V
Note: See TracBrowser for help on using the repository browser.