source: FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXPRO1.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 5.6 KB
Line 
1ECXPRO1 ;ALB/GTS - Prosthetics Extract for DSS (Continued) ; 11/8/07 8:02am
2 ;;3.0;DSS EXTRACTS;**9,11,13,15,21,24,33,37,39,100,105**;Dec 22, 1997;Build 70
3 ;
4NTEG(ECXDFN,ECXLNE,ECXPIEN,ECXN0,ECXNLB,ECINST,ECXFORM) ;** Check for required fields
5 ; Input
6 ; ECXDFN - ien in file #2
7 ; ECXLNE - line number variable (passed by reference)
8 ; ECXPIEN - IEN for the Prosthetics record
9 ; ECXN0 - zero node of the Prosthetics record
10 ; ECXNLB - LB node of the Prosthetics record
11 ; ECINST - station number being extracted
12 ; ECXFORM - Form Requested On
13 ; Output (to be KILLed by calling routine)
14 ; ^TMP("ECX-PRO EXC",$J) - Array for the exception message
15 ; ECXLNE - The number of the next line in the msg
16 ; ECXSTAT2 - Patient Station Number
17 ; ECXDATE - Delivery Date of Prosthesis
18 ; ECXTYPE - Type of Transaction work performed
19 ; ECXSRCE - Source of prosthesis
20 ; ECXHCPCS - CPT/HCPCS code for prosthesis
21 ; ECXRQST - Requesting Station
22 ; ECXRCST - Receiving Station
23 ; ECXPHCPC - PSAS HCPCS code; if 'unknown', then use CPT/HCPCS code
24 ; ECXNPPDC - NPPD code for repairs or new issues
25 ; Output (KILLed by NTEG)
26 ; ECXMISS - 1 indicates missing information
27 ; ECXGOOD - 0 indicates record should not be extracted
28 ;
29 N ECXGOOD,ECXMISS
30 S (ECXRCST,ECXRQST,ECXNPPDC)="",ECXGOOD=1,ECXSTAT2=$P(ECXN0,U,10)
31 I ECXSTAT2]"" D
32 .K ECXDIC
33 .S DA=ECXSTAT2,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
34 .D EN^DIQ1 S ECXSTAT2=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
35 .S:(ECINST'=$E(ECXSTAT2,1,3)) ECXGOOD=0 ;*Screen for incorrect Station
36 ;
37 ;** Screen out records
38 S:($P(ECXN0,U,17)'="") ECXGOOD=0 ;*SHIP/DEL is not NULL
39 S:($P(ECXN0,U,26)'="") ECXGOOD=0 ;*PICKUP/DEL is not NULL
40 S:(+($P($G(^RMPR(660,ECXPIEN,"AM")),U,2))=1) ECXGOOD=0 ;*NO ADMIN CT=1
41 S:(($P(ECXN0,U,15))'="") ECXGOOD=0 ;*HISTORICAL DATA is not NULL
42 ;
43 S ECXDATE=$P(ECXN0,U,12),ECXTYPE=$P(ECXN0,U,4),ECXSRCE=$P(ECXN0,U,14)
44 S ECXHCPCS=$P($G(^ICPT(+$P(ECXN0,U,22),0)),U,1),ECXCMOD=""
45 S ECXHCPCS=$$CPT^ECXUTL3(ECXHCPCS,ECXCMOD)
46 ;get psas hcpcs code from file #661.1
47 S ECXPHCPC=$P($G(^RMPR(660,ECXPIEN,1)),U,4) D
48 .;get nppd code for repairs and new issues 10 characters in length.
49 .I "X5"[ECXTYPE S ECXNPPDC=$TR($$GET1^DIQ(661.1,ECXPHCPC_",",5)," ","_")
50 .I "IR"[ECXTYPE S ECXNPPDC=$TR($$GET1^DIQ(661.1,ECXPHCPC_",",6)," ","_")
51 .I +ECXPHCPC S ECXPHCPC=$E($P($G(^RMPR(661.1,ECXPHCPC,0)),U,1),1,5)
52 .I ECXPHCPC="UNKNOWN" S ECXPHCPC=$E(ECXHCPCS,1,5)
53 ;
54 ;* Get Requesting Station Number
55 I ECXFORM["-3" D
56 .S ECXRQST=$P(ECXNLB,U,1)
57 .I ECXRQST]"" D
58 ..S DA=ECXRQST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
59 ..D EN^DIQ1 S ECXRQST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
60 S:(ECXFORM'["-3") ECXRQST=""
61 ;
62 ;* Screen out records
63 S:(+$P(ECXFORM,U,2)=13) ECXGOOD=0 ;*FORM REQUESTED ON = 13
64 ;
65 ;* Get Receiving Station Number
66 I ECXFORM["-3" D
67 .S ECXRCST=$P(ECXNLB,U,4)
68 .I ECXRCST]"" D
69 ..S DA=ECXRCST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
70 ..D EN^DIQ1 S ECXRCST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
71 S:(ECXFORM'["-3") ECXRCST=""
72 ;
73 ;** Check for integrity and set up the problem variable if right DIV
74 I ECXGOOD D CHK
75 Q ECXGOOD
76 ;
77CHK ;*Check variables
78 ; Input
79 ; Variables set in and Output from NTEG^ECXPRO1
80 ; Output
81 ; ^TMP("ECX-PRO EXC",$J, - Global of records with integrity problems
82 ;
83 S ECXMISS=""
84 I ECXSTAT2']"" S ECXMISS=ECXMISS_"1"
85 S ECXMISS=ECXMISS_U
86 I ECXDFN=0 S ECXMISS=ECXMISS_"1"
87 S ECXMISS=ECXMISS_U
88 ;I ECXSSN']"" S ECXMISS=ECXMISS_"1"
89 S ECXMISS=ECXMISS_U
90 ;I ECXNA=" " S ECXMISS=ECXMISS_"1"
91 S ECXMISS=ECXMISS_U
92 I ECXDATE']"" S ECXMISS=ECXMISS_"1"
93 S ECXMISS=ECXMISS_U
94 I ECXTYPE']"" S ECXMISS=ECXMISS_"1"
95 S ECXMISS=ECXMISS_U
96 I ECXSRCE']"" S ECXMISS=ECXMISS_"1"
97 S ECXMISS=ECXMISS_U
98 I ECXHCPCS']"" S ECXMISS=ECXMISS_"1"
99 S ECXMISS=ECXMISS_U
100 I ECXFORM["-3" D
101 .I ECXRQST']"" S ECXMISS=ECXMISS_"1"
102 S ECXMISS=ECXMISS_U
103 I ECXFORM']"" S ECXMISS=ECXMISS_"1"
104 S ECXMISS=ECXMISS_U
105 I ECXFORM["-3" D
106 .I ECXRCST']"" S ECXMISS=ECXMISS_"1"
107 I ECXMISS'="^^^^^^^^^^" D
108 .S ECXGOOD=0
109 .D ECXMISLN^ECXPRO2(ECXMISS,.ECXLNE,ECXPIEN)
110 Q
111 ;
112PROSINFO(ECXDA,ECXLB,ECX0,ECXFORM) ;*Get Prosthetics Information
113 ;
114 ; Input
115 ; ECDA - The IEN for the Prosthetics record
116 ; ECX0 - The zero node of the Prosthetics record
117 ; ECXLB - The LB node of the Prosthetics record
118 ; ECXFORM - The Form Requested On (to determine Lab transactions)
119 ;
120 ; Output (to be KILLed by calling routine)
121 ; ECXCTAMT - The Cost of Transaction
122 ; ECXLLC - The Lab Labor Cost
123 ; ECXLMC - The Lab Material Cost
124 ; ECXGRPR - The AMIS Grouper number
125 ; ECXBILST - The Billing Status
126 ; ECXQTY - The Quantity
127 ;
128 S (ECXLLC,ECXLMC,ECXCTAMT)="",ECXBILST=$P($G(^RMPR(660,ECXDA,"AM")),U,3)
129 S ECXQTY=$P(ECX0,U,7)
130 S:(+ECXQTY=0) ECXQTY=1
131 ;
132 ;- Set Quantity field to 8 chars (right-justified & padded w/zeros)
133 S ECXQTY=$$RJ^XLFSTR(ECXQTY,8,0)
134 S ECXGRPR=$P($G(^RMPR(660,ECXDA,"AMS")),U,1),ECXCTAMT=$P(ECX0,U,16)
135 I ECXFORM["-3" D
136 .S ECXCTAMT=$P(ECXLB,U,9),ECXLLC=$P(ECXLB,U,7),ECXLMC=$P(ECXLB,U,8)
137 ;
138 ;- If Stock Issue or Inventory Issue, Cost of Transaction=0
139 I $P(ECXFORM,U,2)=11!($P(ECXFORM,U,2)=12) S ECXCTAMT=0
140 S:ECXCTAMT="" ECXCTAMT=0 S:ECXCTAMT>999999 ECXCTAMT=999999
141 S:ECXLLC="" ECXLLC=0 S:ECXLLC>999999 ECXLLC=999999
142 S:ECXLMC="" ECXLMC=0 S:ECXLMC>999999 ECXLMC=999999
143 ;
144 ;- Round to next dollar amount
145 I (ECXCTAMT#1)>.50 S ECXCTAMT=(ECXCTAMT+1)\1
146 I (ECXLLC#1)>.50 S ECXLLC=(ECXLLC+1)\1
147 I (ECXLMC#1)>.50 S ECXLMC=(ECXLMC+1)\1
148 Q
Note: See TracBrowser for help on using the repository browser.