source: FOIAVistA/trunk/r/ASISTS-OOPS/OOPSGUIC.m@ 1801

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

initial load of FOIAVistA 6/30/08 version
File size: 9.3 KB
Line 
1OOPSGUIC ;WIOFO/LLH-RPC routine for GET/SET CA7 ;04/22/04
2 ;;2.0;ASISTS;**8,7**;Jun 03, 2002
3 ;
4CA7LIST(RESULTS,PERSON,CALL) ; builds CA-7 selection list from existing
5 ; cases - not an add
6 ;
7 ; Input: PERSON - person's SSN whether CALL="E" or "W"
8 ; CALL - contains the calling menu and file number in the
9 ; format FILENUM^CALL.
10 ; Output: RESULTS - returns an array containing
11 ; CA7 case #^IEN^DATE OF INCIDENT
12 K ^TMP("CA7LIST",DUZ)
13 N ARR,CA7,CAIEN,CALLER,ESSN,FILE
14 S FILE=$P($G(CALL),U),CALLER=$P($G(CALL),U,2)
15 I $G(PERSON)=""!($G(CALL)="")!($G(FILE)="") D Q
16 . S ^TMP("CA7LIST",DUZ,1)="Not enough info - can't process request"
17 S CAIEN=0,^TMP("CA7LIST",DUZ,1)="No CA-7's Selectable"
18 S ESSN=$$GET1^DIQ(200,DUZ,9)
19 I CALLER="E",ESSN'=PERSON D Q
20 .S ^TMP("CA7LIST",DUZ,1)="User SSN, file SSN do not match-form aborted"
21 F S CAIEN=$O(^OOPS(FILE,"SSN",PERSON,CAIEN)) Q:CAIEN="" D
22 .;if from emp menu & signed by both, don't give access
23 .I CALLER="E",$P($G(^OOPS(FILE,CAIEN,"CA7S7")),U,2)'="",($P($G(^OOPS(FILE,CAIEN,"CA7S15")),U,2)'="") Q
24 .I CALLER="W",(ESSN=PERSON) Q
25 .S CA7=$$GET1^DIQ(FILE,CAIEN,.01),ARR(CA7)=CAIEN
26 ; drop thru here and
27SORT ; reverse the order
28 N CN,CA7,CAIEN,DOI,NM,SSN
29 S ^TMP("CA7LIST",DUZ,0)="",CN=1,CA7=""
30 I '$D(ARR) S ^TMP("CA7LIST",DUZ,1)="No CA7's Selectable"
31 F S CA7=$O(ARR(CA7),-1) Q:CA7="" D
32 .S CAIEN=ARR(CA7)
33 .S ASISTS=$$GET1^DIQ(2260,$$GET1^DIQ(FILE,CAIEN,.7,"I"),52,"I")
34 .S ASISTS="CA-"_$G(ASISTS)
35 .S NM=$E($$GET1^DIQ(FILE,CAIEN,.9),1,27)
36 .S DOI=$$GET1^DIQ(FILE,CAIEN,7)
37 .S SSN=$$GET1^DIQ(FILE,CAIEN,.8)
38 .S ^TMP("CA7LIST",DUZ,CN)=CA7_U_DOI_U_NM_U_ASISTS_U_CAIEN_U_SSN_$C(10)
39 .S CN=CN+1
40 ; then quit
41 S RESULTS=$NA(^TMP("CA7LIST",DUZ))
42 Q
43LISTCA(RESULTS,INPUT) ; returns a list of valid CA (1 or 2) claims that
44 ; can be selected to create a new CA-7
45 ; Input: INPUT - 3 pieces to input parameter
46 ; SSN^FILE^CALLER - CALLER contains either E
47 ; or W (menu called from).
48 ; FILE now only contains 2260 (for CA-1 or 2)
49 ; Output: RESULTS - contains a array of ASISTS Claims with the
50 ; claim number, name, and date of injury. Other
51 ; default fields returned are, grade, step, pay amt,
52 ; pay period, FEGLI Code, and Health Ins.
53 ;
54 K ^TMP("LISTCA",DUZ)
55 N ARR,CAIEN,CALLER,CAIEN,CN,CNUM,DOI,FILE,INJ,NM,PAR,PDFLD,SSN
56 S PAR=$P($G(INPUT),U),FILE=$P($G(INPUT),U,2),CALLER=$P($G(INPUT),U,3)
57 I $G(PAR)=""!($G(FILE)="")!($G(CALLER)="") D Q
58 .S ^TMP("LISTCA",DUZ,0)="Missing parameters - cannot continue"
59 S CAIEN=0
60 F S CAIEN=$O(^OOPS(FILE,"SSN",PAR,CAIEN)) Q:CAIEN="" D
61 .I '$$INCLUDE() Q
62 .I CALLER="E",($$GET1^DIQ(200,DUZ,9)'=PAR) Q
63 .I CALLER="W",($$GET1^DIQ(200,DUZ,9)=PAR) Q
64 .S CNUM=$$GET1^DIQ(FILE,CAIEN,.01),ARR(CNUM)=CAIEN
65 ; No cases to send back
66 I '$D(ARR) D Q
67 .S ^TMP("LISTCA",DUZ,1)="No Cases Selectable"
68 .S RESULTS=$NA(^TMP("LISTCA",DUZ))
69 ; get reverse order
70 S CNUM="",CN=1
71 F S CNUM=$O(ARR(CNUM),-1) Q:CNUM="" D
72 .S CAIEN=ARR(CNUM)
73 .S NM=$$GET1^DIQ(FILE,CAIEN,1)
74 .S DOI=$$GET1^DIQ(FILE,CAIEN,4)
75 .S SSN=$TR($$GET1^DIQ(FILE,CAIEN,5),"-","")
76 .S GRD=$$GET1^DIQ(FILE,CAIEN,16)
77 .S STP=$$GET1^DIQ(FILE,CAIEN,17)
78 .S INJ=$$GET1^DIQ(FILE,CAIEN,52)
79 .S RET=$$GET1^DIQ(FILE,CAIEN,60)
80 .S PAY=$$GET1^DIQ(FILE,CAIEN,166)
81 .S PER=$$GET1^DIQ(FILE,CAIEN,167)
82 .; only need to do this 1 time, should never have but 1 different
83 .; person in this list, many claims but all for the same person
84 .I CN=1 S PDFLD=$$PDDEF()
85 .S STR=CNUM_U_DOI_U_NM_U_CAIEN_U_SSN_U_INJ_U_GRD_U_STP_U_PAY_U_PER
86 .S ^TMP("LISTCA",DUZ,CN)=STR_U_RET_U_PDFLD_U_DUZ_$C(10)
87 .S CN=CN+1
88 S RESULTS=$NA(^TMP("LISTCA",DUZ))
89 Q
90INCLUDE() ; checks to make sure ok to include claim in list
91 N CA7OK
92 S CA7OK=1
93 ; if claim not sent to DOL, can't pick
94 I $$GET1^DIQ(FILE,CAIEN,67)="" S CA7OK=0
95 ; if deleted, replaced by amendment - can't pick
96 I $$GET1^DIQ(FILE,CAIEN,51,"I")>1 S CA7OK=0
97 Q (CA7OK)
98PDDEF() ; get Fegli Code and Health insurance fields from paid
99 N CNT,FEG,FEG1,INS,INS1,PAID
100 S (FEG,FEG1,INS,INS1)=""
101 D FIND^DIC(450,,"@;226EI;231I","MPSC",SSN,10,"SSN")
102 I $G(DIERR) D CLEAN^DILF Q FEG_U_INS
103 I $P(^TMP("DILIST",$J,0),U)=0 Q FEG_U_INS
104 S PAID=$G(^TMP("DILIST",$J,1,0)),FEG=$P(PAID,U,3)
105 ; if A0 - ineligible, B0 - waived therefore No
106 I FEG="A0"!(FEG="B0") S FEG1="N;"
107 ; if C0 - only Basic
108 I FEG="C0" S FEG1="Y;"
109 ; has Fegli, but not basic, additional, get additional code
110 I $G(FEG1)="",($L($P(PAID,U,2),"Basic +")>1) S FEG1="Y;"_FEG
111 ; now deal with insurance
112 S INS=$P(PAID,U,4)
113 ; if INS = 000, 001, 002, 003 they don't have insurance
114 I (INS?.N)&(+INS<4) S INS1="N;"
115 ; otherwise they do, get the code
116 I $G(INS1)="" S INS1="Y;"_INS
117 Q INS1_U_FEG1
118MULTIPLE(RESULTS,INPUT,DATA) ; retrieve data from multiple
119 ; NOTE: When filing into subrecord, the entire subrecord is deleted
120 ; then rebuilt. Also, the field number for the subrecord
121 ; must be passed with the data.
122 ; WORD PROCESSING fields CANNOT file using this code
123 ; Input: INPUT - in the format FILE^FIELD^IEN
124 ; DATA - array of data in the format
125 ; DATA(SIEN)=data where data = P1^P2^P3 etc, where
126 ; P1 = subfield #;data
127 ; DATA="" must be true for a GET.
128 ; Output: RESULTS - data from all records in the multiple will
129 ; be returned. it will be saved in a pieced
130 ; string.
131 N ACTION,ARR,IEN,FIELD,FILE,ROOT,SAVEDIK,SPEC,SUB
132 S FILE=$P($G(INPUT),U),FIELD=$P($G(INPUT),U,2),IEN=$P($G(INPUT),U,3)
133 S ACTION="" I $D(DATA)>1 S ACTION=1
134 S RESULTS(0)="Record Accessed, no data"
135 I $G(IEN)=""!($G(FILE)="")!($G(FIELD)="") D Q
136 . S RESULTS(0)="Invalid parameters cannot continue"
137 S ROOT=$$ROOT^DILFD(FILE,0,"GL")
138 S SPEC=+$$GET1^DID(FILE,FIELD,"","SPECIFIER")
139 S SUB=$$GET1^DID(FILE,FIELD,"","GLOBAL SUBSCRIPT LOCATION")
140 I '$$GET1^DID(FILE,FIELD,"","MULTIPLE-VALUED"),'$G(SPEC) D Q
141 . S RESULTS(1)="Field in not a multiple, cannot continue"
142 ; now go get data from subfile
143 S SAVEDIK=ROOT_IEN_","_$C(34)_$P(SUB,";")_$C(34)_","
144 I 'ACTION D GETD
145 I ACTION D KILLD,SETD
146 Q
147GETD ; get the data
148 N CNT,DATA,FLDA,FLDS,IENS,SIEN,SFLD,SREC,TYPE
149 S CNT=0,IENS=IEN_","
150 S FLDA=FIELD_"*"
151 ; hate to hardwire, but need data back as entered, not canonical
152 I FILE=2262.03,FIELD=15 D FLD15 Q
153 D GETS^DIQ(FILE,IENS,FLDA,,"ARR")
154 I $D(ARR) S SIEN="",RESULTS(0)="" D
155 .F S SIEN=$O(ARR(SPEC,SIEN)) Q:SIEN="" D
156 ..S SFLD="",SREC=$P(SIEN,",")
157 ..F S SFLD=$O(ARR(SPEC,SIEN,SFLD)) Q:SFLD="" D
158 ...S DATA=ARR(SPEC,SIEN,SFLD)_U
159 ...S:$D(RESULTS(CNT))=0 RESULTS(CNT)=""
160 ...S RESULTS(CNT)=RESULTS(CNT)_DATA
161 ..S CNT=CNT+1
162 Q
163KILLD ; first kill all records in subfile, then rebuild
164 N DA,DIK,NODE
165 S NODE=$P(SUB,";"),DA=0,DA(1)=IEN,DIK=SAVEDIK
166 F S DA=$O(@(ROOT_"DA(1),NODE,DA)")) Q:(+DA'>0) D ^DIK
167 Q
168SETD ; subrecord cleaned out, now rebuild
169 N BAD,CN,DR,DIE,DA,DLAYGO,I,NUM,STR,DIC,TYPE
170 K DR
171 S RESULTS(0)="Filing successful"
172 S CN=0,DLAYGO=FILE,DA(1)=IEN,DIC=SAVEDIK,DIC(0)="L"
173 F S CN=$O(DATA(CN)) Q:CN'>0 S X="",BAD=0 D
174 .S STR=DATA(CN),NUM=$L(DATA(CN),U),DIC("DR")=""
175 .F I=1:1:NUM S STR1=$P($G(STR),U,I) D:('BAD)
176 ..I $P(STR1,";")=.01,$P(STR1,";")="",$P(STR1,";",2)="" S BAD=1 Q
177 ..I $P(STR1,";")=.01 D
178 ...S TYPE=$$GET1^DID(SPEC,.01,"","TYPE")
179 ...I TYPE="DATE/TIME" S X=$$FMTE^XLFDT($P(STR1,";",2),2)
180 ...E S X=$P(STR1,";",2)
181 ..S DIC("DR")=DIC("DR")_$P(STR1,";")_"///"_$P(STR1,";",2)_";"
182 .D MFILE
183 Q
184MFILE ; file the multiple
185 N PCE,PCE1,TMP
186 I X="" S RESULTS(0)=".01 field missing - could not file" Q
187 I $G(BAD) S RESULTS(0)="Problems Filing subrecord" Q
188 I $L(DIC("DR"))>240 D
189 .S PCE=$L(DIC("DR"),";"),TMP=DIC("DR"),PCE1=$P(PCE/2,".")
190 .S DIC("DR")=$P(TMP,";",1,PCE1)
191 .K DD,DO D FILE^DICN I Y'>0 S BAD=1
192 .S DIC("DR")=$P(TMP,";",(PCE1+1),PCE)
193 K DD,DO D FILE^DICN I Y'>0 S BAD=1
194 I BAD S RESULTS(0)="Problems filing subrecord"
195 Q
196OSHA300(RESULTS,STA,DATA) ; Files data into subrecord 2262.315
197 ; Input - STA is the station number subrecord IEN
198 ; DATA is an number subscripted array containing the records
199 ; that contain the Emp Numbers and hours worked in the
200 ; OSHA MONTH/YEAR subrecord.
201 ; Output - RESULTS indicating the success of the filing.
202 ;
203 N CNT,IENS,FILE,OSHAFDA,LV1,LV2,PAR,REC,STR
204 S CNT=1,FILE=2262.315
205 S PAR="^OOPS(2262,0)",PAR=$Q(@PAR),PAR=$Q(@PAR)
206 S LV1=$P(PAR,",",2),LV2=$P(PAR,",",3)
207 S RESULTS=""
208 I $D(DATA)<10 S RESULTS="NO DATA TO FILE, CANNOT CONTINUE" Q
209 I '$G(STA) S RESULTS="NOT ENOUGH PARAMETERS, COULDN'T FILE" Q
210 I '$D(^OOPS(2262,LV1,LV2,STA)) D Q
211 .S RESULTS="NO STATION RECORD, COULDN'T FILE"
212 K ^OOPS(2262,LV1,LV2,STA,2)
213 S REC=0 F S REC=$O(DATA(REC)) Q:REC="" D
214 .S IENS="?+"_CNT_","_STA_","_LV1_","
215 .S STR=DATA(REC)
216 .S OSHAFDA(FILE,IENS,.01)=$P($P(STR,U,1),";",2)
217 .S OSHAFDA(FILE,IENS,1)=$P($P(STR,U,2),";",2)
218 .S OSHAFDA(FILE,IENS,2)=$P($P(STR,U,3),";",2)
219 .S CNT=CNT+1
220 D UPDATE^DIE("E","OSHAFDA","IENS","MSG")
221 I '$D(MSG) S RESULTS="Filing Successful"
222 K MSG,STR,Y,X,%DT
223 Q
224FLD15 ; retrieves OSHA 300A Summary data from file 2262
225 N CNT,DATE,LV1,LV2,PAR,REC
226 S CNT=0,PAR="^OOPS(2262,0)",PAR=$Q(@PAR),PAR=$Q(@PAR)
227 S LV1=$P(PAR,",",2),LV2=$P(PAR,",",3),IENS=$P(IEN,",",1),REC=0
228 F S REC=$O(^OOPS(2262,LV1,LV2,IENS,2,REC)) Q:REC'>0 D
229 .S STR=$G(^OOPS(2262,LV1,LV2,IENS,2,REC,0))
230 .S Y=$P(STR,U,1) D DD^%DT
231 .S RESULTS(CNT)=Y_U_$P(STR,U,2,3)
232 .S CNT=CNT+1
233 Q
Note: See TracBrowser for help on using the repository browser.