- OOPSGUIC ;WIOFO/LLH-RPC routine for GET/SET CA7 ;04/22/04
- ;;2.0;ASISTS;**8,7,23,24,25**;Jun 03, 2002;Build 4
- ;
- CA7LIST(RESULTS,PERSON,CALL) ; builds CA-7 selection list from existing
- ; cases - not an add
- ;
- ; Input: PERSON - person's SSN whether CALL="E" or "W"
- ; CALL - contains the calling menu and file number in the
- ; format FILENUM^CALL.
- ; Output: RESULTS - returns an array containing
- ; CA7 case #^IEN^DATE OF INCIDENT
- K ^TMP("CA7LIST",DUZ)
- N ARR,CA7,CAIEN,CALLER,ESSN,FILE
- S FILE=$P($G(CALL),U),CALLER=$P($G(CALL),U,2)
- I $G(PERSON)=""!($G(CALL)="")!($G(FILE)="") D Q
- . S ^TMP("CA7LIST",DUZ,1)="Not enough info - can't process request"
- S CAIEN=0,^TMP("CA7LIST",DUZ,1)="No CA-7's Selectable"
- S ESSN=$$GET1^DIQ(200,DUZ,9)
- I CALLER="E",ESSN'=PERSON D Q
- .S ^TMP("CA7LIST",DUZ,1)="User SSN, file SSN do not match-form aborted"
- F S CAIEN=$O(^OOPS(FILE,"SSN",PERSON,CAIEN)) Q:CAIEN="" D
- .;if from emp menu & signed by both, don't give access
- .I CALLER="E",$P($G(^OOPS(FILE,CAIEN,"CA7S7")),U,2)'="",($P($G(^OOPS(FILE,CAIEN,"CA7S15")),U,2)'="") Q
- .I CALLER="W",(ESSN=PERSON) Q
- .S CA7=$$GET1^DIQ(FILE,CAIEN,.01),ARR(CA7)=CAIEN
- ; drop thru here and
- SORT ; reverse the order
- N CN,CA7,CAIEN,DOI,NM,SSN
- S ^TMP("CA7LIST",DUZ,0)="",CN=1,CA7=""
- I '$D(ARR) S ^TMP("CA7LIST",DUZ,1)="No CA7's Selectable"
- F S CA7=$O(ARR(CA7),-1) Q:CA7="" D
- .S CAIEN=ARR(CA7)
- .S ASISTS=$$GET1^DIQ(2260,$$GET1^DIQ(FILE,CAIEN,.7,"I"),52,"I")
- .S ASISTS="CA-"_$G(ASISTS)
- .S NM=$E($$GET1^DIQ(FILE,CAIEN,.9),1,27)
- .S DOI=$$GET1^DIQ(FILE,CAIEN,7)
- .S SSN=$$GET1^DIQ(FILE,CAIEN,.8)
- .S ^TMP("CA7LIST",DUZ,CN)=CA7_U_DOI_U_NM_U_ASISTS_U_CAIEN_U_SSN_$C(10)
- .S CN=CN+1
- ; then quit
- S RESULTS=$NA(^TMP("CA7LIST",DUZ))
- Q
- LISTCA(RESULTS,INPUT) ; returns a list of valid CA (1 or 2) claims that
- ; can be selected to create a new CA-7
- ; Input: INPUT - 3 pieces to input parameter
- ; SSN^FILE^CALLER - CALLER contains either E
- ; or W (menu called from).
- ; FILE now only contains 2260 (for CA-1 or 2)
- ; Output: RESULTS - contains a array of ASISTS Claims with the
- ; claim number, name, and date of injury. Other
- ; default fields returned are, grade, step, pay amt,
- ; pay period, FEGLI Code, and Health Ins.
- ;
- K ^TMP("LISTCA",DUZ)
- N ARR,CAIEN,CALLER,CAIEN,CN,CNUM,DOI,FILE,INJ,NM,PAR,PDFLD,SSN
- S PAR=$P($G(INPUT),U),FILE=$P($G(INPUT),U,2),CALLER=$P($G(INPUT),U,3)
- I $G(PAR)=""!($G(FILE)="")!($G(CALLER)="") D Q
- .S ^TMP("LISTCA",DUZ,0)="Missing parameters - cannot continue"
- S CAIEN=0
- F S CAIEN=$O(^OOPS(FILE,"SSN",PAR,CAIEN)) Q:CAIEN="" D
- .I '$$INCLUDE() Q
- .I CALLER="E",($$GET1^DIQ(200,DUZ,9)'=PAR) Q
- .I CALLER="W",($$GET1^DIQ(200,DUZ,9)=PAR) Q
- .S CNUM=$$GET1^DIQ(FILE,CAIEN,.01),ARR(CNUM)=CAIEN
- ; No cases to send back
- I '$D(ARR) D Q
- .S ^TMP("LISTCA",DUZ,1)="No Cases Selectable"
- .S RESULTS=$NA(^TMP("LISTCA",DUZ))
- ; get reverse order
- S CNUM="",CN=1
- F S CNUM=$O(ARR(CNUM),-1) Q:CNUM="" D
- .S CAIEN=ARR(CNUM)
- .S NM=$$GET1^DIQ(FILE,CAIEN,1)
- .S DOI=$$GET1^DIQ(FILE,CAIEN,4)
- .S SSN=$TR($$GET1^DIQ(FILE,CAIEN,5),"-","")
- .S GRD=$$GET1^DIQ(FILE,CAIEN,16)
- .S STP=$$GET1^DIQ(FILE,CAIEN,17)
- .S INJ=$$GET1^DIQ(FILE,CAIEN,52)
- .S RET=$$GET1^DIQ(FILE,CAIEN,60)
- .S PAY=$$GET1^DIQ(FILE,CAIEN,166)
- .S PER=$$GET1^DIQ(FILE,CAIEN,167)
- .; only need to do this 1 time, should never have but 1 different
- .; person in this list, many claims but all for the same person
- .I CN=1 S PDFLD=$$PDDEF()
- .S STR=CNUM_U_DOI_U_NM_U_CAIEN_U_SSN_U_INJ_U_GRD_U_STP_U_PAY_U_PER
- .S ^TMP("LISTCA",DUZ,CN)=STR_U_RET_U_PDFLD_U_DUZ_$C(10)
- .S CN=CN+1
- S RESULTS=$NA(^TMP("LISTCA",DUZ))
- Q
- INCLUDE() ; checks to make sure ok to include claim in list
- N CA7OK
- S CA7OK=1
- ; if claim not sent to DOL, can't pick
- I $$GET1^DIQ(FILE,CAIEN,67)="" S CA7OK=0
- ; if deleted, replaced by amendment - can't pick
- I $$GET1^DIQ(FILE,CAIEN,51,"I")>1 S CA7OK=0
- Q (CA7OK)
- PDDEF() ; get Fegli Code and Health insurance fields from paid
- N CNT,FEG,FEG1,INS,INS1,PAID
- S (FEG,FEG1,INS,INS1)=""
- D FIND^DIC(450,,"@;226EI;231I","MPSC",SSN,10,"SSN")
- I $G(DIERR) D CLEAN^DILF Q FEG_U_INS
- I $P(^TMP("DILIST",$J,0),U)=0 Q FEG_U_INS
- S PAID=$G(^TMP("DILIST",$J,1,0)),FEG=$P(PAID,U,3)
- ; if A0 - ineligible, B0 - waived therefore No
- I FEG="A0"!(FEG="B0") S FEG1="N;"
- ; if C0 - only Basic
- I FEG="C0" S FEG1="Y;"
- ; has Fegli, but not basic, additional, get additional code
- I $G(FEG1)="",($L($P(PAID,U,2),"Basic +")>1) S FEG1="Y;"_FEG
- ; now deal with insurance
- S INS=$P(PAID,U,4)
- ; if INS = 000, 001, 002, 003 they don't have insurance
- I (INS?.N)&(+INS<4) S INS1="N;"
- ; otherwise they do, get the code
- I $G(INS1)="" S INS1="Y;"_INS
- Q INS1_U_FEG1
- MULTIPLE(RESULTS,INPUT,DATA) ; retrieve data from multiple
- ; NOTE: When filing into subrecord, the entire subrecord is deleted
- ; then rebuilt. Also, the field number for the subrecord
- ; must be passed with the data.
- ; WORD PROCESSING fields CANNOT file using this code
- ; Input: INPUT - in the format FILE^FIELD^IEN
- ; DATA - array of data in the format
- ; DATA(SIEN)=data where data = P1^P2^P3 etc, where
- ; P1 = subfield #;data
- ; DATA="" must be true for a GET.
- ; Output: RESULTS - data from all records in the multiple will
- ; be returned. it will be saved in a pieced
- ; string.
- N ACTION,ARR,IEN,FIELD,FILE,ROOT,SAVEDIK,SPEC,SUB,OOPSCNT,OOPSSV,OOPSSV1
- S FILE=$P($G(INPUT),U),FIELD=$P($G(INPUT),U,2),IEN=$P($G(INPUT),U,3)
- S ACTION="" I $D(DATA)>1 S ACTION=1
- S RESULTS(0)="Record Accessed, no data"
- I $G(IEN)=""!($G(FILE)="")!($G(FIELD)="") D Q
- . S RESULTS(0)="Invalid parameters cannot continue"
- S ROOT=$$ROOT^DILFD(FILE,0,"GL")
- S SPEC=+$$GET1^DID(FILE,FIELD,"","SPECIFIER")
- S SUB=$$GET1^DID(FILE,FIELD,"","GLOBAL SUBSCRIPT LOCATION")
- I '$$GET1^DID(FILE,FIELD,"","MULTIPLE-VALUED"),'$G(SPEC) D Q
- . S RESULTS(1)="Field in not a multiple, cannot continue"
- ; now go get data from subfile
- S SAVEDIK=ROOT_IEN_","_$C(34)_$P(SUB,";")_$C(34)_","
- ;RRA OOPS*2*23 - ticket 396917
- ;GUI may pass in name as a string - so if there are duplicate names in #200
- ;it doesn't know how to resolve the name to an ien
- ;also adding a "/" (to create a "////") to the fields so they bypass fileman
- ;validation in case the DUZ is 4 digits (could confuse as SSN)
- I ACTION,FILE=2260,FIELD=95 D
- . S OOPSCNT=0
- . F S OOPSCNT=$O(DATA(OOPSCNT)) Q:OOPSCNT'>0 D
- .. S OOPSSV=$P($P($G(DATA(OOPSCNT)),"^",8),";",2)
- .. S OOPSSV1=$P($P($G(DATA(OOPSCNT)),"^",10),";",2)
- .. I '+OOPSSV S OOPSSV=$P($G(^OOPS(2260,IEN,"OUTC",OOPSCNT,0)),"^",8)
- .. I '+OOPSSV1 S OOPSSV1=$P($G(^OOPS(2260,IEN,"OUTC",OOPSCNT,0)),"^",10)
- ..S $P(DATA(OOPSCNT),"^",8)="7;/"_OOPSSV
- ..S $P(DATA(OOPSCNT),"^",10)="9;/"_OOPSSV1
- ;END RRA OOPS*2*23
- I 'ACTION D GETD
- I ACTION D KILLD,SETD
- Q
- GETD ; get the data
- N CNT,DATA,FLDA,FLDS,IENS,SIEN,SFLD,SREC,TYPE
- S CNT=0,IENS=IEN_","
- S FLDA=FIELD_"*"
- ; hate to hardwire, but need data back as entered, not canonical
- I FILE=2262.03,FIELD=15 D FLD15 Q
- ;if Incident Outcome multiple, need to sort in chron order OOPS*25
- I FILE=2260,FIELD=95 D FLD95 Q
- D GETS^DIQ(FILE,IENS,FLDA,,"ARR")
- I $D(ARR) S SIEN="",RESULTS(0)="" D
- .F S SIEN=$O(ARR(SPEC,SIEN)) Q:SIEN="" D
- ..S SFLD="",SREC=$P(SIEN,",")
- ..F S SFLD=$O(ARR(SPEC,SIEN,SFLD)) Q:SFLD="" D
- ...S DATA=ARR(SPEC,SIEN,SFLD)_U
- ...S:$D(RESULTS(CNT))=0 RESULTS(CNT)=""
- ...S RESULTS(CNT)=RESULTS(CNT)_DATA
- ..S CNT=CNT+1
- Q
- KILLD ; first kill all records in subfile, then rebuild
- N DA,DIK,NODE
- S NODE=$P(SUB,";"),DA=0,DA(1)=IEN,DIK=SAVEDIK
- F S DA=$O(@(ROOT_"DA(1),NODE,DA)")) Q:(+DA'>0) D ^DIK
- Q
- SETD ; subrecord cleaned out, now rebuild
- N BAD,CN,DR,DIE,DA,DLAYGO,I,NUM,STR,DIC,TYPE
- K DR
- S RESULTS(0)="Filing successful"
- S CN=0,DLAYGO=FILE,DA(1)=IEN,DIC=SAVEDIK,DIC(0)="L"
- F S CN=$O(DATA(CN)) Q:CN'>0 S X="",BAD=0 D
- .S STR=DATA(CN),NUM=$L(DATA(CN),U),DIC("DR")=""
- .F I=1:1:NUM S STR1=$P($G(STR),U,I) D:('BAD)
- ..I $P(STR1,";")=.01,$P(STR1,";")="",$P(STR1,";",2)="" S BAD=1 Q
- ..I $P(STR1,";")=.01 D
- ...S TYPE=$$GET1^DID(SPEC,.01,"","TYPE")
- ...I TYPE="DATE/TIME" S X=$$FMTE^XLFDT($P(STR1,";",2),2)
- ...E S X=$P(STR1,";",2)
- ..S DIC("DR")=DIC("DR")_$P(STR1,";")_"///"_$P(STR1,";",2)_";"
- .D MFILE
- Q
- MFILE ; file the multiple
- N PCE,PCE1,TMP
- I X="" S RESULTS(0)=".01 field missing - could not file" Q
- I $G(BAD) S RESULTS(0)="Problems Filing subrecord" Q
- I $L(DIC("DR"))>240 D
- .S PCE=$L(DIC("DR"),";"),TMP=DIC("DR"),PCE1=$P(PCE/2,".")
- .S DIC("DR")=$P(TMP,";",1,PCE1)
- .K DD,DO D FILE^DICN I Y'>0 S BAD=1
- .S DIC("DR")=$P(TMP,";",(PCE1+1),PCE)
- K DD,DO D FILE^DICN I Y'>0 S BAD=1
- I BAD S RESULTS(0)="Problems filing subrecord"
- Q
- OSHA300(RESULTS,STA,DATA) ; Files data into subrecord 2262.315
- ; Input - STA is the station number subrecord IEN
- ; DATA is an number subscripted array containing the records
- ; that contain the Emp Numbers and hours worked in the
- ; OSHA MONTH/YEAR subrecord.
- ; Output - RESULTS indicating the success of the filing.
- ;
- N CNT,IENS,FILE,OSHAFDA,LV1,LV2,PAR,REC,STR
- S CNT=1,FILE=2262.315
- S PAR="^OOPS(2262,0)",PAR=$Q(@PAR),PAR=$Q(@PAR)
- S LV1=$P(PAR,",",2),LV2=$P(PAR,",",3)
- S RESULTS=""
- I $D(DATA)<10 S RESULTS="NO DATA TO FILE, CANNOT CONTINUE" Q
- I '$G(STA) S RESULTS="NOT ENOUGH PARAMETERS, COULDN'T FILE" Q
- I '$D(^OOPS(2262,LV1,LV2,STA)) D Q
- .S RESULTS="NO STATION RECORD, COULDN'T FILE"
- K ^OOPS(2262,LV1,LV2,STA,2)
- S REC=0 F S REC=$O(DATA(REC)) Q:REC="" D
- .S IENS="?+"_CNT_","_STA_","_LV1_","
- .S STR=DATA(REC)
- .S OSHAFDA(FILE,IENS,.01)=$P($P(STR,U,1),";",2)
- .S OSHAFDA(FILE,IENS,1)=$P($P(STR,U,2),";",2)
- .S OSHAFDA(FILE,IENS,2)=$P($P(STR,U,3),";",2)
- .S CNT=CNT+1
- D UPDATE^DIE("E","OSHAFDA","IENS","MSG")
- I '$D(MSG) S RESULTS="Filing Successful"
- K MSG,STR,Y,X,%DT
- Q
- FLD15 ; retrieves OSHA 300A Summary data from file 2262
- N CNT,DATE,LV1,LV2,PAR,REC
- S CNT=0,PAR="^OOPS(2262,0)",PAR=$Q(@PAR),PAR=$Q(@PAR)
- S LV1=$P(PAR,",",2),LV2=$P(PAR,",",3),IENS=$P(IEN,",",1),REC=0
- F S REC=$O(^OOPS(2262,LV1,LV2,IENS,2,REC)) Q:REC'>0 D
- .S STR=$G(^OOPS(2262,LV1,LV2,IENS,2,REC,0))
- .S Y=$P(STR,U,1) D DD^%DT
- .S RESULTS(CNT)=Y_U_$P(STR,U,2,3)
- .S CNT=CNT+1
- Q
- FLD95 ; sort Incident Outcomes so they display in chron order OOPS*25
- N OOPSCNT,OOPSSREC,OOPSIEN,OOPSSUB,OOPSFLD,OOPSDATA,OOPSARR
- S OOPSCNT=0
- D GETS^DIQ(FILE,IENS,FLDA,,"ARR")
- ;rebuild array so when it $O's it goes through in chron order
- I $D(ARR) S OOPSSUB="",RESULTS(0)="" D
- .F S OOPSSUB=$O(ARR(SPEC,OOPSSUB)) Q:OOPSSUB="" D
- ..S OOPSSREC=$P(OOPSSUB,","),OOPSIEN=$P(OOPSSUB,",",2),OOPSFLD=""
- ..F S OOPSFLD=$O(ARR(SPEC,OOPSSUB,OOPSFLD)) Q:OOPSFLD="" D
- ...S OOPSARR(OOPSSREC,OOPSFLD)=ARR(SPEC,OOPSSUB,OOPSFLD)
- ;now go through the new subscripted array and process
- S OOPSSREC=""
- F S OOPSSREC=$O(OOPSARR(OOPSSREC)) Q:OOPSSREC="" D
- .S OOPSFLD=""
- .F S OOPSFLD=$O(OOPSARR(OOPSSREC,OOPSFLD)) Q:OOPSFLD="" D
- ..S OOPSDATA=OOPSARR(OOPSSREC,OOPSFLD)_U
- ..S:$D(RESULTS(OOPSCNT))=0 RESULTS(OOPSCNT)=""
- ..S RESULTS(OOPSCNT)=RESULTS(OOPSCNT)_OOPSDATA
- .S OOPSCNT=OOPSCNT+1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOOPSGUIC 11566 printed Feb 18, 2025@23:05:31 Page 2
- OOPSGUIC ;WIOFO/LLH-RPC routine for GET/SET CA7 ;04/22/04
- +1 ;;2.0;ASISTS;**8,7,23,24,25**;Jun 03, 2002;Build 4
- +2 ;
- CA7LIST(RESULTS,PERSON,CALL) ; builds CA-7 selection list from existing
- +1 ; cases - not an add
- +2 ;
- +3 ; Input: PERSON - person's SSN whether CALL="E" or "W"
- +4 ; CALL - contains the calling menu and file number in the
- +5 ; format FILENUM^CALL.
- +6 ; Output: RESULTS - returns an array containing
- +7 ; CA7 case #^IEN^DATE OF INCIDENT
- +8 KILL ^TMP("CA7LIST",DUZ)
- +9 NEW ARR,CA7,CAIEN,CALLER,ESSN,FILE
- +10 SET FILE=$PIECE($GET(CALL),U)
- SET CALLER=$PIECE($GET(CALL),U,2)
- +11 IF $GET(PERSON)=""!($GET(CALL)="")!($GET(FILE)="")
- Begin DoDot:1
- +12 SET ^TMP("CA7LIST",DUZ,1)="Not enough info - can't process request"
- End DoDot:1
- QUIT
- +13 SET CAIEN=0
- SET ^TMP("CA7LIST",DUZ,1)="No CA-7's Selectable"
- +14 SET ESSN=$$GET1^DIQ(200,DUZ,9)
- +15 IF CALLER="E"
- IF ESSN'=PERSON
- Begin DoDot:1
- +16 SET ^TMP("CA7LIST",DUZ,1)="User SSN, file SSN do not match-form aborted"
- End DoDot:1
- QUIT
- +17 FOR
- SET CAIEN=$ORDER(^OOPS(FILE,"SSN",PERSON,CAIEN))
- if CAIEN=""
- QUIT
- Begin DoDot:1
- +18 ;if from emp menu & signed by both, don't give access
- +19 IF CALLER="E"
- IF $PIECE($GET(^OOPS(FILE,CAIEN,"CA7S7")),U,2)'=""
- IF ($PIECE($GET(^OOPS(FILE,CAIEN,"CA7S15")),U,2)'="")
- QUIT
- +20 IF CALLER="W"
- IF (ESSN=PERSON)
- QUIT
- +21 SET CA7=$$GET1^DIQ(FILE,CAIEN,.01)
- SET ARR(CA7)=CAIEN
- End DoDot:1
- +22 ; drop thru here and
- SORT ; reverse the order
- +1 NEW CN,CA7,CAIEN,DOI,NM,SSN
- +2 SET ^TMP("CA7LIST",DUZ,0)=""
- SET CN=1
- SET CA7=""
- +3 IF '$DATA(ARR)
- SET ^TMP("CA7LIST",DUZ,1)="No CA7's Selectable"
- +4 FOR
- SET CA7=$ORDER(ARR(CA7),-1)
- if CA7=""
- QUIT
- Begin DoDot:1
- +5 SET CAIEN=ARR(CA7)
- +6 SET ASISTS=$$GET1^DIQ(2260,$$GET1^DIQ(FILE,CAIEN,.7,"I"),52,"I")
- +7 SET ASISTS="CA-"_$GET(ASISTS)
- +8 SET NM=$EXTRACT($$GET1^DIQ(FILE,CAIEN,.9),1,27)
- +9 SET DOI=$$GET1^DIQ(FILE,CAIEN,7)
- +10 SET SSN=$$GET1^DIQ(FILE,CAIEN,.8)
- +11 SET ^TMP("CA7LIST",DUZ,CN)=CA7_U_DOI_U_NM_U_ASISTS_U_CAIEN_U_SSN_$CHAR(10)
- +12 SET CN=CN+1
- End DoDot:1
- +13 ; then quit
- +14 SET RESULTS=$NAME(^TMP("CA7LIST",DUZ))
- +15 QUIT
- LISTCA(RESULTS,INPUT) ; returns a list of valid CA (1 or 2) claims that
- +1 ; can be selected to create a new CA-7
- +2 ; Input: INPUT - 3 pieces to input parameter
- +3 ; SSN^FILE^CALLER - CALLER contains either E
- +4 ; or W (menu called from).
- +5 ; FILE now only contains 2260 (for CA-1 or 2)
- +6 ; Output: RESULTS - contains a array of ASISTS Claims with the
- +7 ; claim number, name, and date of injury. Other
- +8 ; default fields returned are, grade, step, pay amt,
- +9 ; pay period, FEGLI Code, and Health Ins.
- +10 ;
- +11 KILL ^TMP("LISTCA",DUZ)
- +12 NEW ARR,CAIEN,CALLER,CAIEN,CN,CNUM,DOI,FILE,INJ,NM,PAR,PDFLD,SSN
- +13 SET PAR=$PIECE($GET(INPUT),U)
- SET FILE=$PIECE($GET(INPUT),U,2)
- SET CALLER=$PIECE($GET(INPUT),U,3)
- +14 IF $GET(PAR)=""!($GET(FILE)="")!($GET(CALLER)="")
- Begin DoDot:1
- +15 SET ^TMP("LISTCA",DUZ,0)="Missing parameters - cannot continue"
- End DoDot:1
- QUIT
- +16 SET CAIEN=0
- +17 FOR
- SET CAIEN=$ORDER(^OOPS(FILE,"SSN",PAR,CAIEN))
- if CAIEN=""
- QUIT
- Begin DoDot:1
- +18 IF '$$INCLUDE()
- QUIT
- +19 IF CALLER="E"
- IF ($$GET1^DIQ(200,DUZ,9)'=PAR)
- QUIT
- +20 IF CALLER="W"
- IF ($$GET1^DIQ(200,DUZ,9)=PAR)
- QUIT
- +21 SET CNUM=$$GET1^DIQ(FILE,CAIEN,.01)
- SET ARR(CNUM)=CAIEN
- End DoDot:1
- +22 ; No cases to send back
- +23 IF '$DATA(ARR)
- Begin DoDot:1
- +24 SET ^TMP("LISTCA",DUZ,1)="No Cases Selectable"
- +25 SET RESULTS=$NAME(^TMP("LISTCA",DUZ))
- End DoDot:1
- QUIT
- +26 ; get reverse order
- +27 SET CNUM=""
- SET CN=1
- +28 FOR
- SET CNUM=$ORDER(ARR(CNUM),-1)
- if CNUM=""
- QUIT
- Begin DoDot:1
- +29 SET CAIEN=ARR(CNUM)
- +30 SET NM=$$GET1^DIQ(FILE,CAIEN,1)
- +31 SET DOI=$$GET1^DIQ(FILE,CAIEN,4)
- +32 SET SSN=$TRANSLATE($$GET1^DIQ(FILE,CAIEN,5),"-","")
- +33 SET GRD=$$GET1^DIQ(FILE,CAIEN,16)
- +34 SET STP=$$GET1^DIQ(FILE,CAIEN,17)
- +35 SET INJ=$$GET1^DIQ(FILE,CAIEN,52)
- +36 SET RET=$$GET1^DIQ(FILE,CAIEN,60)
- +37 SET PAY=$$GET1^DIQ(FILE,CAIEN,166)
- +38 SET PER=$$GET1^DIQ(FILE,CAIEN,167)
- +39 ; only need to do this 1 time, should never have but 1 different
- +40 ; person in this list, many claims but all for the same person
- +41 IF CN=1
- SET PDFLD=$$PDDEF()
- +42 SET STR=CNUM_U_DOI_U_NM_U_CAIEN_U_SSN_U_INJ_U_GRD_U_STP_U_PAY_U_PER
- +43 SET ^TMP("LISTCA",DUZ,CN)=STR_U_RET_U_PDFLD_U_DUZ_$CHAR(10)
- +44 SET CN=CN+1
- End DoDot:1
- +45 SET RESULTS=$NAME(^TMP("LISTCA",DUZ))
- +46 QUIT
- INCLUDE() ; checks to make sure ok to include claim in list
- +1 NEW CA7OK
- +2 SET CA7OK=1
- +3 ; if claim not sent to DOL, can't pick
- +4 IF $$GET1^DIQ(FILE,CAIEN,67)=""
- SET CA7OK=0
- +5 ; if deleted, replaced by amendment - can't pick
- +6 IF $$GET1^DIQ(FILE,CAIEN,51,"I")>1
- SET CA7OK=0
- +7 QUIT (CA7OK)
- PDDEF() ; get Fegli Code and Health insurance fields from paid
- +1 NEW CNT,FEG,FEG1,INS,INS1,PAID
- +2 SET (FEG,FEG1,INS,INS1)=""
- +3 DO FIND^DIC(450,,"@;226EI;231I","MPSC",SSN,10,"SSN")
- +4 IF $GET(DIERR)
- DO CLEAN^DILF
- QUIT FEG_U_INS
- +5 IF $PIECE(^TMP("DILIST",$JOB,0),U)=0
- QUIT FEG_U_INS
- +6 SET PAID=$GET(^TMP("DILIST",$JOB,1,0))
- SET FEG=$PIECE(PAID,U,3)
- +7 ; if A0 - ineligible, B0 - waived therefore No
- +8 IF FEG="A0"!(FEG="B0")
- SET FEG1="N;"
- +9 ; if C0 - only Basic
- +10 IF FEG="C0"
- SET FEG1="Y;"
- +11 ; has Fegli, but not basic, additional, get additional code
- +12 IF $GET(FEG1)=""
- IF ($LENGTH($PIECE(PAID,U,2),"Basic +")>1)
- SET FEG1="Y;"_FEG
- +13 ; now deal with insurance
- +14 SET INS=$PIECE(PAID,U,4)
- +15 ; if INS = 000, 001, 002, 003 they don't have insurance
- +16 IF (INS?.N)&(+INS<4)
- SET INS1="N;"
- +17 ; otherwise they do, get the code
- +18 IF $GET(INS1)=""
- SET INS1="Y;"_INS
- +19 QUIT INS1_U_FEG1
- MULTIPLE(RESULTS,INPUT,DATA) ; retrieve data from multiple
- +1 ; NOTE: When filing into subrecord, the entire subrecord is deleted
- +2 ; then rebuilt. Also, the field number for the subrecord
- +3 ; must be passed with the data.
- +4 ; WORD PROCESSING fields CANNOT file using this code
- +5 ; Input: INPUT - in the format FILE^FIELD^IEN
- +6 ; DATA - array of data in the format
- +7 ; DATA(SIEN)=data where data = P1^P2^P3 etc, where
- +8 ; P1 = subfield #;data
- +9 ; DATA="" must be true for a GET.
- +10 ; Output: RESULTS - data from all records in the multiple will
- +11 ; be returned. it will be saved in a pieced
- +12 ; string.
- +13 NEW ACTION,ARR,IEN,FIELD,FILE,ROOT,SAVEDIK,SPEC,SUB,OOPSCNT,OOPSSV,OOPSSV1
- +14 SET FILE=$PIECE($GET(INPUT),U)
- SET FIELD=$PIECE($GET(INPUT),U,2)
- SET IEN=$PIECE($GET(INPUT),U,3)
- +15 SET ACTION=""
- IF $DATA(DATA)>1
- SET ACTION=1
- +16 SET RESULTS(0)="Record Accessed, no data"
- +17 IF $GET(IEN)=""!($GET(FILE)="")!($GET(FIELD)="")
- Begin DoDot:1
- +18 SET RESULTS(0)="Invalid parameters cannot continue"
- End DoDot:1
- QUIT
- +19 SET ROOT=$$ROOT^DILFD(FILE,0,"GL")
- +20 SET SPEC=+$$GET1^DID(FILE,FIELD,"","SPECIFIER")
- +21 SET SUB=$$GET1^DID(FILE,FIELD,"","GLOBAL SUBSCRIPT LOCATION")
- +22 IF '$$GET1^DID(FILE,FIELD,"","MULTIPLE-VALUED")
- IF '$GET(SPEC)
- Begin DoDot:1
- +23 SET RESULTS(1)="Field in not a multiple, cannot continue"
- End DoDot:1
- QUIT
- +24 ; now go get data from subfile
- +25 SET SAVEDIK=ROOT_IEN_","_$CHAR(34)_$PIECE(SUB,";")_$CHAR(34)_","
- +26 ;RRA OOPS*2*23 - ticket 396917
- +27 ;GUI may pass in name as a string - so if there are duplicate names in #200
- +28 ;it doesn't know how to resolve the name to an ien
- +29 ;also adding a "/" (to create a "////") to the fields so they bypass fileman
- +30 ;validation in case the DUZ is 4 digits (could confuse as SSN)
- +31 IF ACTION
- IF FILE=2260
- IF FIELD=95
- Begin DoDot:1
- +32 SET OOPSCNT=0
- +33 FOR
- SET OOPSCNT=$ORDER(DATA(OOPSCNT))
- if OOPSCNT'>0
- QUIT
- Begin DoDot:2
- +34 SET OOPSSV=$PIECE($PIECE($GET(DATA(OOPSCNT)),"^",8),";",2)
- +35 SET OOPSSV1=$PIECE($PIECE($GET(DATA(OOPSCNT)),"^",10),";",2)
- +36 IF '+OOPSSV
- SET OOPSSV=$PIECE($GET(^OOPS(2260,IEN,"OUTC",OOPSCNT,0)),"^",8)
- +37 IF '+OOPSSV1
- SET OOPSSV1=$PIECE($GET(^OOPS(2260,IEN,"OUTC",OOPSCNT,0)),"^",10)
- +38 SET $PIECE(DATA(OOPSCNT),"^",8)="7;/"_OOPSSV
- +39 SET $PIECE(DATA(OOPSCNT),"^",10)="9;/"_OOPSSV1
- End DoDot:2
- End DoDot:1
- +40 ;END RRA OOPS*2*23
- +41 IF 'ACTION
- DO GETD
- +42 IF ACTION
- DO KILLD
- DO SETD
- +43 QUIT
- GETD ; get the data
- +1 NEW CNT,DATA,FLDA,FLDS,IENS,SIEN,SFLD,SREC,TYPE
- +2 SET CNT=0
- SET IENS=IEN_","
- +3 SET FLDA=FIELD_"*"
- +4 ; hate to hardwire, but need data back as entered, not canonical
- +5 IF FILE=2262.03
- IF FIELD=15
- DO FLD15
- QUIT
- +6 ;if Incident Outcome multiple, need to sort in chron order OOPS*25
- +7 IF FILE=2260
- IF FIELD=95
- DO FLD95
- QUIT
- +8 DO GETS^DIQ(FILE,IENS,FLDA,,"ARR")
- +9 IF $DATA(ARR)
- SET SIEN=""
- SET RESULTS(0)=""
- Begin DoDot:1
- +10 FOR
- SET SIEN=$ORDER(ARR(SPEC,SIEN))
- if SIEN=""
- QUIT
- Begin DoDot:2
- +11 SET SFLD=""
- SET SREC=$PIECE(SIEN,",")
- +12 FOR
- SET SFLD=$ORDER(ARR(SPEC,SIEN,SFLD))
- if SFLD=""
- QUIT
- Begin DoDot:3
- +13 SET DATA=ARR(SPEC,SIEN,SFLD)_U
- +14 if $DATA(RESULTS(CNT))=0
- SET RESULTS(CNT)=""
- +15 SET RESULTS(CNT)=RESULTS(CNT)_DATA
- End DoDot:3
- +16 SET CNT=CNT+1
- End DoDot:2
- End DoDot:1
- +17 QUIT
- KILLD ; first kill all records in subfile, then rebuild
- +1 NEW DA,DIK,NODE
- +2 SET NODE=$PIECE(SUB,";")
- SET DA=0
- SET DA(1)=IEN
- SET DIK=SAVEDIK
- +3 FOR
- SET DA=$ORDER(@(ROOT_"DA(1),NODE,DA)"))
- if (+DA'>0)
- QUIT
- DO ^DIK
- +4 QUIT
- SETD ; subrecord cleaned out, now rebuild
- +1 NEW BAD,CN,DR,DIE,DA,DLAYGO,I,NUM,STR,DIC,TYPE
- +2 KILL DR
- +3 SET RESULTS(0)="Filing successful"
- +4 SET CN=0
- SET DLAYGO=FILE
- SET DA(1)=IEN
- SET DIC=SAVEDIK
- SET DIC(0)="L"
- +5 FOR
- SET CN=$ORDER(DATA(CN))
- if CN'>0
- QUIT
- SET X=""
- SET BAD=0
- Begin DoDot:1
- +6 SET STR=DATA(CN)
- SET NUM=$LENGTH(DATA(CN),U)
- SET DIC("DR")=""
- +7 FOR I=1:1:NUM
- SET STR1=$PIECE($GET(STR),U,I)
- if ('BAD)
- Begin DoDot:2
- +8 IF $PIECE(STR1,";")=.01
- IF $PIECE(STR1,";")=""
- IF $PIECE(STR1,";",2)=""
- SET BAD=1
- QUIT
- +9 IF $PIECE(STR1,";")=.01
- Begin DoDot:3
- +10 SET TYPE=$$GET1^DID(SPEC,.01,"","TYPE")
- +11 IF TYPE="DATE/TIME"
- SET X=$$FMTE^XLFDT($PIECE(STR1,";",2),2)
- +12 IF '$TEST
- SET X=$PIECE(STR1,";",2)
- End DoDot:3
- +13 SET DIC("DR")=DIC("DR")_$PIECE(STR1,";")_"///"_$PIECE(STR1,";",2)_";"
- End DoDot:2
- +14 DO MFILE
- End DoDot:1
- +15 QUIT
- MFILE ; file the multiple
- +1 NEW PCE,PCE1,TMP
- +2 IF X=""
- SET RESULTS(0)=".01 field missing - could not file"
- QUIT
- +3 IF $GET(BAD)
- SET RESULTS(0)="Problems Filing subrecord"
- QUIT
- +4 IF $LENGTH(DIC("DR"))>240
- Begin DoDot:1
- +5 SET PCE=$LENGTH(DIC("DR"),";")
- SET TMP=DIC("DR")
- SET PCE1=$PIECE(PCE/2,".")
- +6 SET DIC("DR")=$PIECE(TMP,";",1,PCE1)
- +7 KILL DD,DO
- DO FILE^DICN
- IF Y'>0
- SET BAD=1
- +8 SET DIC("DR")=$PIECE(TMP,";",(PCE1+1),PCE)
- End DoDot:1
- +9 KILL DD,DO
- DO FILE^DICN
- IF Y'>0
- SET BAD=1
- +10 IF BAD
- SET RESULTS(0)="Problems filing subrecord"
- +11 QUIT
- OSHA300(RESULTS,STA,DATA) ; Files data into subrecord 2262.315
- +1 ; Input - STA is the station number subrecord IEN
- +2 ; DATA is an number subscripted array containing the records
- +3 ; that contain the Emp Numbers and hours worked in the
- +4 ; OSHA MONTH/YEAR subrecord.
- +5 ; Output - RESULTS indicating the success of the filing.
- +6 ;
- +7 NEW CNT,IENS,FILE,OSHAFDA,LV1,LV2,PAR,REC,STR
- +8 SET CNT=1
- SET FILE=2262.315
- +9 SET PAR="^OOPS(2262,0)"
- SET PAR=$QUERY(@PAR)
- SET PAR=$QUERY(@PAR)
- +10 SET LV1=$PIECE(PAR,",",2)
- SET LV2=$PIECE(PAR,",",3)
- +11 SET RESULTS=""
- +12 IF $DATA(DATA)<10
- SET RESULTS="NO DATA TO FILE, CANNOT CONTINUE"
- QUIT
- +13 IF '$GET(STA)
- SET RESULTS="NOT ENOUGH PARAMETERS, COULDN'T FILE"
- QUIT
- +14 IF '$DATA(^OOPS(2262,LV1,LV2,STA))
- Begin DoDot:1
- +15 SET RESULTS="NO STATION RECORD, COULDN'T FILE"
- End DoDot:1
- QUIT
- +16 KILL ^OOPS(2262,LV1,LV2,STA,2)
- +17 SET REC=0
- FOR
- SET REC=$ORDER(DATA(REC))
- if REC=""
- QUIT
- Begin DoDot:1
- +18 SET IENS="?+"_CNT_","_STA_","_LV1_","
- +19 SET STR=DATA(REC)
- +20 SET OSHAFDA(FILE,IENS,.01)=$PIECE($PIECE(STR,U,1),";",2)
- +21 SET OSHAFDA(FILE,IENS,1)=$PIECE($PIECE(STR,U,2),";",2)
- +22 SET OSHAFDA(FILE,IENS,2)=$PIECE($PIECE(STR,U,3),";",2)
- +23 SET CNT=CNT+1
- End DoDot:1
- +24 DO UPDATE^DIE("E","OSHAFDA","IENS","MSG")
- +25 IF '$DATA(MSG)
- SET RESULTS="Filing Successful"
- +26 KILL MSG,STR,Y,X,%DT
- +27 QUIT
- FLD15 ; retrieves OSHA 300A Summary data from file 2262
- +1 NEW CNT,DATE,LV1,LV2,PAR,REC
- +2 SET CNT=0
- SET PAR="^OOPS(2262,0)"
- SET PAR=$QUERY(@PAR)
- SET PAR=$QUERY(@PAR)
- +3 SET LV1=$PIECE(PAR,",",2)
- SET LV2=$PIECE(PAR,",",3)
- SET IENS=$PIECE(IEN,",",1)
- SET REC=0
- +4 FOR
- SET REC=$ORDER(^OOPS(2262,LV1,LV2,IENS,2,REC))
- if REC'>0
- QUIT
- Begin DoDot:1
- +5 SET STR=$GET(^OOPS(2262,LV1,LV2,IENS,2,REC,0))
- +6 SET Y=$PIECE(STR,U,1)
- DO DD^%DT
- +7 SET RESULTS(CNT)=Y_U_$PIECE(STR,U,2,3)
- +8 SET CNT=CNT+1
- End DoDot:1
- +9 QUIT
- FLD95 ; sort Incident Outcomes so they display in chron order OOPS*25
- +1 NEW OOPSCNT,OOPSSREC,OOPSIEN,OOPSSUB,OOPSFLD,OOPSDATA,OOPSARR
- +2 SET OOPSCNT=0
- +3 DO GETS^DIQ(FILE,IENS,FLDA,,"ARR")
- +4 ;rebuild array so when it $O's it goes through in chron order
- +5 IF $DATA(ARR)
- SET OOPSSUB=""
- SET RESULTS(0)=""
- Begin DoDot:1
- +6 FOR
- SET OOPSSUB=$ORDER(ARR(SPEC,OOPSSUB))
- if OOPSSUB=""
- QUIT
- Begin DoDot:2
- +7 SET OOPSSREC=$PIECE(OOPSSUB,",")
- SET OOPSIEN=$PIECE(OOPSSUB,",",2)
- SET OOPSFLD=""
- +8 FOR
- SET OOPSFLD=$ORDER(ARR(SPEC,OOPSSUB,OOPSFLD))
- if OOPSFLD=""
- QUIT
- Begin DoDot:3
- +9 SET OOPSARR(OOPSSREC,OOPSFLD)=ARR(SPEC,OOPSSUB,OOPSFLD)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +10 ;now go through the new subscripted array and process
- +11 SET OOPSSREC=""
- +12 FOR
- SET OOPSSREC=$ORDER(OOPSARR(OOPSSREC))
- if OOPSSREC=""
- QUIT
- Begin DoDot:1
- +13 SET OOPSFLD=""
- +14 FOR
- SET OOPSFLD=$ORDER(OOPSARR(OOPSSREC,OOPSFLD))
- if OOPSFLD=""
- QUIT
- Begin DoDot:2
- +15 SET OOPSDATA=OOPSARR(OOPSSREC,OOPSFLD)_U
- +16 if $DATA(RESULTS(OOPSCNT))=0
- SET RESULTS(OOPSCNT)=""
- +17 SET RESULTS(OOPSCNT)=RESULTS(OOPSCNT)_OOPSDATA
- End DoDot:2
- +18 SET OOPSCNT=OOPSCNT+1
- End DoDot:1
- +19 QUIT