source: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXPRO1.m@ 636

Last change on this file since 636 was 636, checked in by George Lilly, 14 years ago

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