source: WorldVistAEHR/trunk/r/E_CLAIMS_MGMT_ENGINE-BPS/BPSOSSG.m@ 823

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

initial load of WorldVistAEHR
File size: 5.4 KB
RevLine 
[613]1BPSOSSG ;BHAM ISC/SD/lwj/FLS - Special gets for formats ;06/01/2004
2 ;;1.0;E CLAIMS MGMT ENGINE;**1,5**;JUN 2004;Build 45
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 Q
6 ;
7FLD439 ;Reason for service code
8 ;Called by SET logic in BPS NCPDP Field DEFS for field 439
9 ;DUR is newed in BPSOSHF
10 I ^BPS(9002313.99,1,"CERTIFIER")=DUZ S DUR=1
11 S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,2)=BPS("X")
12 Q
13 ;
14FLD440 ;Professional Service Code
15 ;Called by set logic in BPS NCPDP Field DEFS for field 440
16 ;DUR is newed in BPSOSHF
17 I ^BPS(9002313.99,1,"CERTIFIER")=DUZ S DUR=1
18 S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,3)=BPS("X")
19 Q
20 ;
21FLD441 ;Result of Service Code
22 ;Called by SET logic in BPS NCPDP Field DEFS for field 441
23 ;DUR is newed in BPSOSHF
24 I ^BPS(9002313.99,1,"CERTIFIER")=DUZ S DUR=1
25 S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,4)=BPS("X")
26 Q
27 ;
28FLD473 ;DUR/PPS code counter - called from SET logic in BPS NCPDP Field Defs
29 ;DUR is newed in BPSOSHF
30 I ^BPS(9002313.99,1,"CERTIFIER")=DUZ S DUR=1
31 S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,1)=BPS("X")
32 S ^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,"B",BPS("X"),DUR)=""
33 Q
34FLD474 ;DUR/PPS level of effort - called from set logic in BPS NCPDP Field
35 ;DUR is newed in BPSOSHF
36 I ^BPS(9002313.99,1,"CERTIFIER")=DUZ S DUR=1
37 S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,5)=BPS("X")
38 Q
39 ;
40FLD475 ;DUR Co-agent ID Qualifier - called from set logic in BPS NCPDP Field
41 ;DUR is newed in BPSOSHF
42 I ^BPS(9002313.99,1,"CERTIFIER")=DUZ S DUR=1
43 S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,6)=BPS("X")
44 Q
45 ;
46FLD476 ;DUR Co-agent ID - called from set logic in BPS NCPDP Field
47 ;DUR is newed in BPSOSHF
48 I ^BPS(9002313.99,1,"CERTIFIER")=DUZ S DUR=1
49 S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,7)=BPS("X")
50 Q
51 ;
52FLD480 ;Other Amount Claimed Submitted field
53 ;Called by set logic in BPS NCPDP Field DEFS for field 480
54 ;Sets fields 478, 479, and 480 in BPS Claims
55 Q:BPS("X")=""!(BPS("X")=0)!($TR(BPS("X"),"{}0.H7H8H9")="")
56 N FDA,MSG
57 S FDA(9002313.0601,"+1,"_BPS(9002313.0201)_","_BPS(9002313.02)_",",.01)="H7"_1
58 S FDA(9002313.0601,"+1,"_BPS(9002313.0201)_","_BPS(9002313.02)_",",480)=BPS("X")
59 S FDA(9002313.0601,"+1,"_BPS(9002313.0201)_","_BPS(9002313.02)_",",479)="H8"_$G(BPS("Insurer","Other Amt Claim Sub Qual"))
60 D UPDATE^DIE("","FDA","BPS(9002313.0601)","MSG")
61 I $D(MSG) D
62 . D LOG2CLM^BPSOSL(BPS(9002313.02),$T(+0)_"-Failed to update NCPDP field 480 and/or 479")
63 . D LOGARAY2^BPSOSL(BPS(9002313.02),"MSG")
64 Q
65 ;
66EMPL ;Get employer info
67 ; This by GET logic in BPS NCPDP Field Defs for field 315 (Employer Name)
68 ; DMB 11/13/2006 - It makes some sense to only set these fields if
69 ; they exist on the payer sheet. However, it assumes that the
70 ; employer name field will always be before the other fields and
71 ; that the other fields will not exist without the Employer Name
72 ; field. For now, leave this be as these fields are on the
73 ; Worker's Comp segment, which we do not do. We may want to evaluate
74 ; if we were to ever add the Worker's Comp segment
75 Q:'$G(BPS("Patient","IEN"))
76 D GETS^DIQ(2,BPS("Patient","IEN"),".3111;.3112;.3113;.3115;.3116;.3117;.3118;.3119","","EMPL")
77 S BPS("Employer","Name")=EMPL(2,BPS("Patient","IEN")_",",.3111)
78 S:EMPL(2,BPS("Patient","IEN")_",",.3111)=""&(EMPL(2,BPS("Patient","IEN")_",",.3112)'="") BPS("Employer","Name")=EMPL(2,BPS("Patient","IEN")_",",.3112)
79 S BPS("Employer","Address")=EMPL(2,BPS("Patient","IEN")_",",.3113)
80 S BPS("Employer","City")=EMPL(2,BPS("Patient","IEN")_",",.3116)
81 S BPS("Employer","State")=EMPL(2,BPS("Patient","IEN")_",",.3117)
82 I BPS("Employer","State")'="" D
83 . S STATEIEN="",STATEIEN=$O(^DIC(5,"B",BPS("Employer","State"),STATEIEN)),BPS("Employer","State")=$P($G(^DIC(5,STATEIEN,0)),"^",2)
84 S BPS("Employer","Zip Code")=EMPL(2,BPS("Patient","IEN")_",",.3118)
85 S BPS("Employer","Phone")=EMPL(2,BPS("Patient","IEN")_",",.3119)
86 K EMPL,STATEIEN
87 Q
88 ;
89STLIC(STATE) ; Retrieve the state license number.
90 ; This can be called by the special code in the payer sheet
91 ; References to State file (DIC(5)) covered by IA 10056
92 ; References to New Person file (VA(200)) covered by IA 10060
93 ;
94 ;
95 ; Validate the STATE parameter
96 I $G(STATE)="" Q ""
97 ;
98 ; Get state IEN and make sure it exists
99 N STIEN
100 S STIEN=$O(^DIC(5,"C",STATE,0))
101 I STIEN="" Q ""
102 ;
103 ; Get Provider IEN and make sure it exist
104 N PROVIEN
105 S PROVIEN=$G(BPS("RX",BPS(9002313.02),"Prescriber IEN"))
106 I PROVIEN="" Q ""
107 ;
108 ; Get the expiration date and compare to the date of service
109 N EXPDT
110 S EXPDT=$$GET1^DIQ(200.541,STIEN_","_PROVIEN_",",2)
111 I EXPDT,EXPDT+17000000<$G(BPS("RX",BPS(9002313.02),"Date Filled")) Q ""
112 ;
113 ; Get the license number
114 Q $$GET1^DIQ(200.541,STIEN_","_PROVIEN_",",1)
115 ;
116STDEA(STATE) ; Retrieve the state DEA number.
117 ; This can be called by the special code in the payer sheet
118 ; References to State file (DIC(5)) covered by IA 10056
119 ; References to New Person file (VA(200)) covered by IA 10060
120 ;
121 ; Validate the STATE parameter
122 I $G(STATE)="" Q ""
123 ;
124 ; Get state IEN and make sure it exists
125 N STIEN
126 S STIEN=$O(^DIC(5,"C",STATE,0))
127 I STIEN="" Q ""
128 ;
129 ; Get Provider IEN and make sure it exist
130 N PROVIEN
131 S PROVIEN=$G(BPS("RX",BPS(9002313.02),"Prescriber IEN"))
132 I PROVIEN="" Q ""
133 ;
134 ; Get the license number
135 Q $$GET1^DIQ(200.55,STIEN_","_PROVIEN_",",1)
Note: See TracBrowser for help on using the repository browser.