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 Dec 13, 2024@01:39:08 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
