source: FOIAVistA/trunk/r/ASISTS-OOPS/OOPSXP8.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 6.7 KB
Line 
1OOPSXP8 ;WIOFO/LLH-INIT ROUTINE FOR PATCH 8 ;5/1/2000
2 ;;1.0;ASISTS;**8**;Jun 01, 1998
3 ;
4VAL(IEN) ; Determine pay rate, convert if called from ????
5 ; input - IEN of case
6 ; output - VAL returns 1 is field is convertable
7 ; - PAY is set to the conversion value to be set into fld 167
8 ; in the subroutine PAY below
9 ;
10 ; Code to test for a value of 1,2,6 is included as defensive code
11 ; in the event that the package file check fails and this code is
12 ; run more than once. It 'protects' valid codes. These values should
13 ; not be present prior to the conversion.
14 ;
15 N STR,VAL
16 S STR=$G(^OOPS(2260,IEN,"CA1L")),PAY=$P($G(STR),U,2)
17 S PAY=$$UP^OOPSUTL4(PAY),PAY=$TR(PAY,"- ","")
18 I PAY="Y"!(PAY="YR")!($E(PAY,1,4)="YEAR")!(PAY="A")!(PAY="AN")!($E(PAY,1,4)="ANNU") S PAY="ANNUAL"
19 I PAY="H"!(PAY="HR")!($E(PAY,1,4)="HOUR") S PAY="HOURLY"
20 I PAY="W"!(PAY=1)!(PAY="WK")!($E(PAY,1,4)="WEEK") S PAY="WEEKLY"
21 I PAY="B"!(PAY=2)!(PAY="BI")!($E(PAY,1,4)="BIWE") S PAY="BI-WEEKLY"
22 I PAY="D"!(PAY=6)!(PAY="DA")!(PAY="DAILY")!(PAY="PERDIEM") S PAY="DAILY"
23 S VAL=$S(PAY="ANNUAL":1,PAY="HOURLY":1,PAY="WEEKLY":1,PAY="BI-WEEKLY":1,PAY="DAILY":1,PAY="":1,1:0)
24 Q VAL
25POST ;
26 N MSG,PAY,PMSG
27 S MSG(1)=" "
28 S MSG(2)="The PAY RATE PER Field (#167) in the ASISTS ACCIDENT REPORTING "
29 S MSG(3)="File (#2260) has been changed from a free text field to a "
30 S MSG(4)="set of codes field."
31 S MSG(5)="This routine will convert the current data in the PAY RATE PER "
32 S MSG(6)="field for cases that a valid code can be determined."
33 S MSG(7)="The Set of Codes are: "
34 S MSG(8)="1 - Weekly H - Hourly"
35 S MSG(9)="2 - Bi-weekly A - Annual"
36 S MSG(10)="6 - Daily"
37 S MSG(11)="Any case that the correct code cannot be determined for will"
38 S MSG(12)="be included in the install file and the PAY RATE PER data deleted."
39 S MSG(13)="An option is provided with the patch that will allow"
40 S MSG(14)="a user to correct the data after installation of the patch."
41 S MSG(15)="If required (cases are present with data that could not be "
42 S MSG(16)="converted), install the option as a secondary menu on the"
43 S MSG(17)="appropriate users' menu and instruct them to make the data"
44 S MSG(18)="corrections."
45 ;
46 I $$PATCH^XPDUTL("OOPS*1.0*8") D Q
47 . D BMES^XPDUTL(" Skipping post install since patch was previously installed.")
48 D BMES^XPDUTL("Data Conversion in Progress...") H 1
49 D MES^XPDUTL(" ")
50 D PAY
51 I PMSG D MES^XPDUTL(.MSG) H 3
52 D DICT
53 K DIC,DLAYGO
54 Q
55 ;
56PAY ; Convert the PAY RATE PER field to the set of codes. Also convert
57 ; the WITNESS NAME (#115) and move to WITNESS NAME (#2260.0125,.01)
58 N IEN,INJ,DR,DA,DIE,WITNM
59 S IEN=0,DIE="^OOPS(2260,",PMSG=0
60 F S IEN=$O(^OOPS(2260,IEN)) Q:IEN'>0 D
61 . S WITNM=$P($G(^OOPS(2260,IEN,"CA1D")),U)
62 . I $G(WITNM)'="" D
63 .. ; set the witness name into new field, kill #115)
64 .. S ^OOPS(2260,IEN,"CA1W",0)="^2260.0125A^1^1"
65 .. S $P(^OOPS(2260,IEN,"CA1W",1,0),U)=WITNM
66 .. S ^OOPS(2260,IEN,"CA1W","B",WITNM,1)=""
67 .. S $P(^OOPS(2260,IEN,"CA1D"),U)=""
68 . S INJ=$P($G(^OOPS(2260,IEN,0)),U,7)
69 . I INJ=1 D
70 .. I '$$VAL(IEN) D Q
71 ... D MES^XPDUTL("Pay Rate Per cannot be converted for Case "_$$GET1^DIQ(2260,IEN,.01,"E")_" - "_$$GET1^DIQ(2260,IEN,167,"I"))
72 ... S $P(^OOPS(2260,IEN,"CA1L"),U,2)="",PMSG=1
73 .. S DA=IEN,DR="167///^S X=PAY"
74 .. D:PAY]"" ^DIE
75 D BMES^XPDUTL("Pay Rate Per Conversion complete.")
76 Q
77DICT NEW DIE,DA,DIC,X,DR,I
78 K DES,CODE,MODCODE,NEWCODE
79MODC F I=1:1 S MODCODE=$P($T(MODCODE+I),";;",2) Q:MODCODE="" D
80 . K DO,DD,DR
81 . S (DIC,DIE)="^OOPS(2261.1,",DR=""
82 . S DA=$P(MODCODE,";",3)
83 . Q:'DA
84 . S DES=$P(MODCODE,";",2),CODE=$P(MODCODE,";")
85 . Q:($$GET1^DIQ(2261.1,DA,.01,"E")=DES)
86 . S DR(1,2261.1,1)=".01////^S X=DES"
87 . S DR(1,2261.1,2)="1////^S X=CODE"
88 . D ^DIE
89 K DES,CODE,MODCODE
90NEWC F I=1:1 S NEWCODE=$P($T(NEWCODE+I),";;",2) Q:NEWCODE="" D
91 . S DIC="^OOPS(2261.1,",DIC(0)="LQZ",DLAYGO=2261.1
92 . S X=$P(NEWCODE,";",2),CODE=$P(NEWCODE,";")
93 . Q:$D(^OOPS(2261.1,"C",CODE)) ; don't set if code exists
94 . S DIC("DR")="1////^S X=CODE"
95 . K DO,DD D FILE^DICN K DLAYGO
96 K CODE,DES,NEWCODE
97 D BMES^XPDUTL("Table updates completed.")
98 Q
99 ;
100MODCODE(LINE) ; MODIFY BODY PART DESCRIPTION AND CODE
101 ;;BA;ABDOMEN;1
102 ;;BC;CHEST;7
103 ;;HF;FACE;11
104 ;;CM;MOUTH;18
105 ;;HK;NECK;19
106 ;;CN;NOSE, INTERNAL;20
107 ;;BZ;EXTERNAL, EXTERNAL, OTHER;21
108 ;;RP;PELVIS;22
109 ;;RB;RIB;23
110 ;;CC;SKULL (CRANIAL BONES);25
111 ;;BL;LOWER BACK/BUTTOCKS;29
112 ;;
113NEWCODE(LINE) ; ADD NEW BODY PART CODE AND DESCRIPTION
114 ;;AB;BOTH ARMS AND/OR WRIST
115 ;;AS;SINGLE ARM AND/OR WRIST
116 ;;B1;SINGLE BREAST
117 ;;B2;BOTH BREASTS
118 ;;B3;SINGLE TESTICLE
119 ;;B4;BOTH TESTICLES
120 ;;BP;PENIS
121 ;;BS;SIDE/FLANK
122 ;;BU;UPPER BACK
123 ;;BW;WAIST
124 ;;C1;SINGLE EAR
125 ;;C2;BOTH EARS
126 ;;C3;SINGLE EYE
127 ;;C4;BOTH EYES
128 ;;CB;BRAIN
129 ;;CD;TEETH
130 ;;CJ;JAW, MANDIBLE
131 ;;CL;LARYNX
132 ;;CR;THROAT, OTHER
133 ;;CT;TONGUE
134 ;;CZ;HEAD, INTERNAL, OTHER
135 ;;EB;BOTH ELBOWS
136 ;;ES;SINGLE ELBOW
137 ;;F1;SINGLE FIRST FINGER
138 ;;F2;BOTH FIRST FINGERS
139 ;;F3;SINGLE SECOND FINGER
140 ;;F4;BOTH SECOND FINGERS
141 ;;F5;SINGLE THIRD FINGER
142 ;;F6;BOTH THIRD FINGERS
143 ;;F7;SINGLE FOURTH FINGER
144 ;;F8;BOTH FOURTH FINGERS
145 ;;G1;SINGLE GREAT TOE
146 ;;G2;BOTH GREAT TOES
147 ;;G3;OTH/MULT TOE(S), SINGLE FOOT
148 ;;G4;OTH/MUTL TOE(S), BOTH FEET
149 ;;H1;SINGLE EYE (EXTERNAL)
150 ;;H2;BOTH EYES (EXTERNAL)
151 ;;H3;SINGLE EAR (EXTERNAL)
152 ;;H4;BOTH EARS (EXTERNAL)
153 ;;HC;CHIN
154 ;;HM;LIPS
155 ;;HN;NOSE
156 ;;HS;SCALP
157 ;;KB;BOTH KNEES
158 ;;KS;SINGLE KNEE
159 ;;LB;BOTH LEGS/HIPS/ANKLES/BUTTOCKS
160 ;;LS;SINGLE LEG/HIP/ANKLE/BUTTOCK
161 ;;MB;BOTH HANDS
162 ;;MS;SINGLE HAND
163 ;;PB;BOTH FEET
164 ;;PS;SINGLE FOOT
165 ;;R1;SINGLE CLAVICLE
166 ;;R2;BOTH CLAVICLES
167 ;;R3;SINGLE SCAPULA
168 ;;R4;BOTH SCAPULAE
169 ;;RS;STERNUM
170 ;;RV;VERTEBRA (SPINE, SPINAL COL)
171 ;;RZ;TRUNK BONE, OTHER
172 ;;SB;BOTH SHOULDERS
173 ;;SS;SINGLE SHOULDER
174 ;;TB;BOTH THUMBS
175 ;;TS;SINGLE THUMB
176 ;;V1;SINGLE LUNG
177 ;;V2;BOTH LUNGS
178 ;;V3;SINGLE KIDNEY
179 ;;V4;BOTH KIDNEYS
180 ;;VH;HEART
181 ;;VL;LIVER
182 ;;VR;REPRODUCTIVE ORGANS
183 ;;VS;STOMACH
184 ;;VI;Intestines
185 ;;VZ;TRUNK, INTERNAL, OTHER
186 ;;L4;BOTH LOWER LEG/ANKLES
187 ;;A1;SINGLE UPPER ARM
188 ;;A2;BOTH UPPER ARMS
189 ;;A3;SINGLE FOREARM
190 ;;A4;BOTH FOREARMS
191 ;;A5;SINGLE WRIST
192 ;;A6;BOTH WRISTS
193 ;;AZ;ARM(S), OTHER
194 ;;AX;ARM(S), MULTIPLE SITES
195 ;;FS;MULTIPLE FINGERS, SINGLE HAND
196 ;;FB;MULTIPLE FINGERS, BOTH HANDS
197 ;;L1;SINGLE HIP/THIGH
198 ;;L2;BOTH HIPS/THIGHS
199 ;;L3;SINGLE LOWER LEG/ANKLE
200 ;;LZ;LEG(S), OTHER
201 ;;LX;LEG(S), MULTIPLE SITES
202 ;;HZ;HEAD, EXTERNAL, OTHER
203 ;;HX;HEAD, EXTERNAL, MULTIPLE SITES
204 ;;CK;BONES OF FACE, OTHER(S)
205 ;;CS;SINUS (ES)
206 ;;CX;HEAD, INTERNAL, MULTIPLE SITES
207 ;;B5;VULVA/VAGINA
208 ;;BX;TRUNK, EXTERNAL, MULT SITES
209 ;;RC;RIBS, MULTIPLE
210 ;;RX;TRUNK, MULTIPLE BONES
211 ;;V5;BLADDER, URETHRA
212 ;;VC;SPINAL CORD
213 ;;VN;NERVE
214 ;;VM;SPLEEN
215 ;;VX;TRUNK, INTERNAL, MULT ORGANS
216 ;;XX;MULTIPLE ANATOMICAL SITES
217 ;;XZ;ANATOMIC SITE NOT MENTIONED
218 ;;
219 Q
Note: See TracBrowser for help on using the repository browser.