ACHSEOBB ; IHS/ITSC/TPF/PMF - PROCESS EOBRS (2/6) CONTINUATION ;
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**21,22,23**;JUN 11, 2001;Build 43
;ACHS*3.1*22;FIXED SCC IN B RECORD;CHANGES FOR ALLOWING PROCESS OF ICD9 FILE FIX
;
; ACHS*3.1*23 9.19.13 IHS.OIT.FCJ CHANGED TO CHECK FOR RECORD "J" ICD-10 RECORDS
; ACHS*3.1*23 9.19.13 IHS.OIT.FCJ ADDED J REC, MODS TO G REC FIXED H REC
;
M1 ;EP
;
;IF CAME IN THRU OPTION ACHSFEOBR THEN PRINT CANCEL DOCUMENTS
I ACHSISAO,$$AOP^ACHS(2,6)="Y" D ^ACHSEOB2
;
;IF 'UPDATE DOCUMENT FROM EOBR' = YES THEN CALL UPDATE DOCUMENT
;DOES THIS REALLY SWITCH DUZ(2)'S - yes it does. pmf
I 'ACHSISAO,$$PARM^ACHS(2,15)="Y" S ACHSDUZ2=DUZ(2) D ^ACHSEOB3 S ACHSYAYA=19,DUZ(2)=ACHSDUZ2 D ^ACHSUF K ACHSYAYA
;
;I 'PRINT EOBR'S' = YES PRINT EOBR SUMMARY REPORT
;I 'ACHSISAO,$$PARM^ACHS(2,14)="Y" D ^ACHSEOB2 ;ACHS*3.1*21
;
;A= HEADING A H=SUMMARY
I $E(ACHSEOBR,19)'="A"!$E(ACHSEOBR,19)'="H"!$E(ACHSEOBR,1,2)'="**" G M1A
U IO(0)
;IF CHAR 19 NOT EQUAL TO 'A' OR 'H' OR FIRST TWO CHARS NOT '**' THEN ERROR??????
W *7,*7,!!,"LAST RECORD READ WAS OUT OF SEQUENCE",!!,"CONTACT YOUR SITEMANAGER - SEE ^ACHSEOBR(""SEQ-ERROR"").",!!
S ^ACHSEOBR("SEQ-ERROR")=ACHSEOBR,ACHSTERR=5 ;CHAR 19 ERROR
Q
;
M1A ;
I $G(ACHSEOBR("A",12))'="" D
.S ^ACHSEOBR("P",$E(ACHSEOBR("A",12),2,12),ACHSCTR(1))=ACHSZFPT
.S ACHSOLD=$E(ACHSEOBR,1,18)
.S X=ACHSEOBR
K ^TMP("ACHSEOB",$J),ACHSEOBR,ACHSERRE
S ACHSEOBR=X
Q
;
REC ;EP
I $L(ACHSEOBR)<80 S ACHSEOBR=ACHSEOBR_$J("",80-$L(ACHSEOBR))
;I "ABCDEFGHI"'[$E(ACHSEOBR,19) U IO(0) W *7,!,"A Record was found that was not type 'A' thru 'I'.",!,"'",ACHSEOBR,"'" S ACHSTERR=10 Q
I "ABCDEFGHIJ"'[$E(ACHSEOBR,19) U IO(0) W *7,!,"A Record was found that was not type 'A' thru 'J'.",!,"'",ACHSEOBR,"'" S ACHSTERR=10 Q ;ACHS*3.1*23
;
PRT ;EP - From EOBR Error Report.
;DETAIL RECORD
I $E(ACHSEOBR,19)="F" D REC1 S ^TMP("ACHSEOB",$J,"F",+$E(ACHSEOBR,20,22))=ACHSEOBR D GBLD^ACHSEOB1 Q
;
;PROCEDURES RECORD
I $E(ACHSEOBR,19)="G" S ^TMP("ACHSEOB",$J,"G",+$E(ACHSEOBR,20,22))=$E(ACHSEOBR,23,65) Q
;
REC1 ;EP - Set values of EOBR being processed into local array.
D REC2(ACHSEOBR,.ACHSEOBR)
S ACHSREJ=$S($D(ACHSEOBR("E")):"E",$D(ACHSEOBR("J")):"J",1:"") ;ACHS*3.1*23
Q
;NEW SECTION OF CODE
REC2(ACHSREC,ACHSARRY) ;EP - DIVIDE A RECORD INTO ITS RESPECTIVE FIELDS
;
N ACHS,ACHSRT,ACHSRL
S ACHSRT=$E(ACHSREC,19)
I ACHSRT="C",$E(ACHSREC,20,22)="002" S ACHSRT="CA"
I ACHSRT="H",$E(ACHSREC,20,22)="002" S ACHSRT="HA" ;ACHS*3.1*21
I ACHSRT="G",$$PARM^ACHS(0,17),DT>($$PARM^ACHS(0,17)-1) S ACHSRT="G1" ;ACHS*3.1*23
I ACHSRT="E",$$PARM^ACHS(0,17),DT>($$PARM^ACHS(0,17)-1) S ACHSRT="E1" ;ACHS*3.1*23
I ACHSRT="E",$P($G(ACHSMEDA),".",2)="ICD" S ACHSRT="E1" ;ACHS*3.1*22 USE E1 ICD-CODE W DEC
S ACHSRL=$T(@ACHSRT)
;ACHS*3.1*23 NEW SECTION FOR PROCESSING "J" RECORD
I ACHSRT="J" D
.S ACHSRJCT=+$E(ACHSREC,20,22),ACHSEDXT=ACHSRJCT*3 ;TOTAL DX
.F ACHS=2:1 S X=$P(ACHSRL,";;",ACHS) Q:X="" D
..D SIGN^ACHSEOB1:$P(X,".",4)="S"
..I ((ACHS=15)!(ACHS=16)!(ACHS=17))&(ACHSRJCT>1) D Q
...S ACHSARRY(ACHSRT,$P(X+ACHSEDXT,"."))=$E(ACHSREC,$P(X,".",2),$P(X,".",3))
..S ACHSARRY(ACHSRT,$P(X,"."))=$E(ACHSREC,$P(X,".",2),$P(X,".",3))
;REPLACED NXT 3 LINES WITH $S
;I ACHSRT="CA" S ACHSRT="C"
;I ACHSRT="HA" S ACHSRT="H" ;ACHS*3.1*21
;I ACHSRT="E1" S ACHSRT="E" ;ACHS*3.1*22 RESET VAR TO E
S ACHSRT=$S(ACHSRT="CA":"C",ACHSRT="HA":"H",ACHSRT="E1":"E",ACHSRT="G1":"G",1:ACHSRT)
F ACHS=2:1 S X=$P(ACHSRL,";;",ACHS) Q:X="" D SIGN^ACHSEOB1:$P(X,".",4)="S" S ACHSARRY(ACHSRT,$P(X,"."))=$E(ACHSREC,$P(X,".",2),$P(X,".",3))
Q
;
; fld# . start_position . end_position . Sign ; See Tech Manual for rec layout
; Y2K changes
; TAG A CH: 11.46.51 TO 11.46.53 (CCYYMMDD)
; CH: 12.52.63 TO 12.54.65 -- SHIFTED
; CH: 13.64.70 TO 13.66.72 -- SHIFTED
; CH: 14.71.76 TO 14.73.78 -- SHIFTED
; CH: 15.77.78 TO 15.79.80 -- SHIFTED
A ;;1.1.2;;2.3.4;;3.5.6;;4.7.8;;5.9.18;;8.23.31;;9.32.38;;10.39.45;;11.46.53;;12.54.65;;13.66.72;;14.73.78;;15.79.80
;
; TAG B RECORD CHANGED ACHS*3.1*22
; 13.73.74;;14.75.78 TO 14.71.76
B ;;8.23.52;;9.53.59;;10.60.67;;11.68.69;;12.70.72;;14.73.76
;
; Y2K changes
; TAG C CH: 14.56.61 DROPPED
; CH: 15.62.67 DROPPED
; CH: 16.68.80 TO 16.56.68
C ;;8.23.38;;9.39.42;;10.43.43;;11.44.44;;12.45.54;;13.55.55;;16.56.68
;
CA ;;14.23.30;;15.31.38
;
D ;;8.23.52;;9.53.61.S;;10.62.70.S;;11.71.79.S
;
E ;;8.23.31.S;;9.32.32;;10.33.41.S;;11.42.50.S;;12.51.55;;13.56.60;;14.61.65;;15.66.70;;16.71.75
;ACHS*3.1*22 NEW E1 LINE TO READ IN DX CODE WITH DECIMAL USED FOR ICD9 FX
; CH: 12.51.55 to 12.51.56 -- SHIFTED
; CH: 13.56.60 to 13.57.62 -- SHIFTED
; CH: 14.61.65 to 14.63.68 -- SHIFTED
; CH: 15.66.70 to 15.69.74 -- SHIFTED
; CH: 16.71.75 to 16.75.80 -- SHIFTED
E1 ;;8.23.31.S;;9.32.32;;10.33.41.S;;11.42.50.S;;12.51.56;;13.57.62;;14.63.68;;15.69.74;;16.75.80
;
; Y2K changes
; TAG F ADD: 7.20.22
; CH: 8.23.28 TO 8.23.30 (CCYYMMDD)
; CH: 9.29.34 TO 9.31.38 (CCYYMMDD)
; CH: 10.35.39 TO 10.39.43 -- SHIFTED
; CH: 11.40.42 TO 11.44.46 -- SHIFTED
; CH: 12.43.51 TO 12.47.55 -- SHIFTED
; CH: 13.52.60 TO 13.56.64 -- SHIFTED
; CH: 14.61.64 TO 14.65.68 -- SHIFTED
; CH: 15.65.66 TO 15.69.70 -- SHIFTED
; CH: 16.67.71 TO 16.71.75 -- SHIFTED
F ;;7.20.22;;8.23.30;;9.31.38;;10.39.43;;11.44.46;;12.47.55.S;;13.56.64.S;;14.65.68;;15.69.70;;16.71.75
;
G ;;8.23.26;;9.27.30;;10.31.34
;
;ACHS*3.1*23 CHANGE TO THIS FOR ICD-10
G1 ;;8.23.29;;9.30.36;;10.37.43;11.44.50;12.51.57
;
; Y2K chsnges
; TAG H CH: 9.29.34 DROPPED
; CH: 10.35.40 DROPPED
; ADD: 16.66.70
H ;;1.1.2;;2.3.4;;4.7.8;;8.23.28;;11.41.45;;12.46.50;;13.51.55;;14.56.65.S;;16.66.70;;15.71.80.S
;
HA ;;9.23.30;;10.31.38
I ;;8.23.29;;9.30.33;;10.34.38.S;;11.39.41;;12.42.50.S;;13.51.56.S;;14.57.66.S
;
;ACHS*3.1*23 NEW J DX RECORD FOR ICD-10
J ;;8.23.31.S;;9.32.32;;10.33.41.S;;11.42.50.S;;12.51.58;;13.59.66;;14.67.74
;
;
AREA ;EP - Update Area parameter file after processing FI EOBR file.
S:'$D(^ACHSAOP(DUZ(2),17,0)) ^ACHSAOP(DUZ(2),17,0)=$$ZEROTH^ACHS(9002079,17)
S DIC="^ACHSAOP("_DUZ(2)_",17,",DA(1)=DUZ(2),DIC(0)="LMN",X=ACHSEOBD,DINUM=X
K DD,DO D FILE^DICN
I +Y<1 U IO(0) W !,*7,"UNABLE TO POST EOBR PROCESS DATE - NOTIFY SUPERVISOR",!,$$DIR^XBDIR("E","Enter <RETURN> to Continue")
S $P(^ACHSAOP(DUZ(2),2),U,11)=ACHSEOBD
;S $P(^ACHSAOP(DUZ(2),2),U,9)=+$P(ACHSUFLS(ACHSFILE),U,5) ;ACHS*3.1*22
S:+ACHSAOSQ'=0 $P(^ACHSAOP(DUZ(2),2),U,9)=+$P(ACHSUFLS(ACHSFILE),U,5) ;ACHS*3.1*22;DO NOT SET IF ICD9 FILE
S:+$P(^ACHSAOP(DUZ(2),2),U,9)=999 $P(^ACHSF(DUZ(2),2),U,9)=0
S:ACHSMCNT>0 $P(^ACHSAOP(DUZ(2),2),U,10)=DT
Q:'$L($$AOP^ACHS(2,7))
I $$MV^%ZISH($$AOP^ACHS(2,1),ACHSMEDA,$$AOP^ACHS(2,7),ACHSMEDA) W !,*7,"Archive of '",$$AOP^ACHS(2,1),ACHSMEDA,"' to '",$$AOP^ACHS(2,7),ACHSMEDA,"' failed..." I 1
E W !,"'",$$AOP^ACHS(2,1),ACHSMEDA,"' Archived to '",$$AOP^ACHS(2,7),ACHSMEDA,"'"
S ACHSISAC=1 ;ACHS*3.1*21 ADDED VAR FOR CONTINUING TO SPLIT OUT
Q
;
FAC ;EP - Update CHS FACILITY with EOB Seq # and Process date.
S:'$D(^ACHSF(DUZ(2),17,0)) ^ACHSF(DUZ(2),17,0)=$$ZEROTH^ACHS(9002080,17)
S DIC="^ACHSF("_DUZ(2)_",17,",DIC(0)="LMN",DA(1)=DUZ(2),X=ACHSEOBD,DINUM=X
K DD,DO D FILE^DICN
S $P(^ACHSF(DUZ(2),2),U,21)=ACHSSEQN
Q
;
FACSRCH ;EP
K ACHSUFLS
I $$LIST^%ZISH($$IM^ACHS,ACHSMEDA_"*",.ACHSUFLS) G ABEND^ACHSEOB
Q:'$O(ACHSUFLS(0))
S ACHSUFLS=0
C01 ;
S ACHSUFLS=$O(ACHSUFLS(ACHSUFLS))
G C0END:+ACHSUFLS=0
S Y=ACHSUFLS(ACHSUFLS)
I $$OS^ACHS=1,Y[".z" D
.S ACHSHCMD="unpack "_$$IM^ACHS_Y
.;
.;IHS/ITSC/PMF 1/12/01 change call of vendor routine to call
.;of routine in our namespace.
.S ACHSRTCD=$$TERMINAL^ACHSHCMD(ACHSHCMD)
.;
.S ACHSUFLS(ACHSUFLS)=$P(Y,".z",1)
.Q
;
I $$OS^ACHS=1,Y[".Z" D
.S ACHSHCMD="uncompress "_$$IM^ACHS_Y
.;
.;IHS/ITSC/PMF 1/12/01 change call of vendor routine to call
.;of routine in our namespace.
.S ACHSRTCD=$$TERMINAL^ACHSHCMD(ACHSHCMD)
.;
.S ACHSUFLS(ACHSUFLS)=$P(Y,".Z",1)
;
I $$OPEN^%ZISH($$IM^ACHS,ACHSUFLS(ACHSUFLS),"R") G ABEND^ACHSEOB
U IO
R X:DTIME ;SAC-FILE READ
E G ABEND^ACHSEOB
D ^%ZISC
I $E(X,1,2)'="$$" S $P(ACHSUFLS(ACHSUFLS)," ",5)="BAD" G C01
S ACHSUFLS(ACHSUFLS)=ACHSUFLS(ACHSUFLS)_" "_$P(X,"$$",2)
G C01
;
C0END ;
S IONOFF=""
D ^%ZISC
D FILDEL^ACHSEOBC
C1 ;
U IO(0)
W !!," Files Available for Processing are Listed Below:",!?40,"Last Fac Seq # Processed = ",$J($$PARM^ACHS(2,21),5)
W !!?5,"Number",?15,"File Name",?45,"EOBR Proc Date",?65,"Fac Seq #",!?5,"------",?15,"----------------",?45,"--------------",?65,"---------"
S (ACHSI,ACHSJ,ACHSII)=0
C2 ;
S ACHSII=$O(ACHSUFLS("C",ACHSII))
G C5:+ACHSII=0
S ACHSI=0
C3 ;
S ACHSI=$O(ACHSUFLS("C",ACHSII,ACHSI))
G C2:+ACHSI=0
S ACHSJ=ACHSJ+1,ACHSK(ACHSJ)=ACHSI
U IO(0)
W !?5,$J(ACHSJ,3),?15,$P(ACHSUFLS(ACHSK(ACHSJ))," ",1),?45,$$FMTE^XLFDT($P(ACHSUFLS(ACHSK(ACHSJ))," ",2)),?67,$J(+$P(ACHSUFLS(ACHSK(ACHSJ))," ",3),5)
G C3
;
C5 ;
Q
;
KILL ;EP
;ACHS*3.1*21 REMOVED ACHSISAO
K %MT,ACHSDIEN,ACHSCTR,ACHSDA,ACHSDERR,ACHSDOCR,ACHSDUZ2,ACHSEOBR,ACHSEOIO,ACHSMSG,ACHSOLD,ACHSTERR,ACHSTDA,DX,DY,ACHSMEDA,ACHSMEDY,ACHSSUF
K ACHSDATE,ACHSDELD,ACHSDSAV,ACHSEBET,ACHSEOBD,ACHSERDT,ACHSERPT,ACHSERR,ACHSERRC,ACHSFILE,ACHSFNAM,ACHSFSIZ,ACHSHCMD
K ACHSHFS1,ACHSI,ACHSII,ACHSISEQ,ACHSLCTR,ACHSLEOB,ACHSLMT,ACHSMCNT,ACHSMFLG,ACHSMSEQ,ACHSOMSG,ACHSPDT,ACHSPG,ACHSQUIT,ACHSR,ACHSRCT,ACHSRDAT,ACHSRPT,ACHSRR,ACHSSEL,ACHSTIME,ACHSUFLS
K ACHSXX,ACHSZ3,ACHSZFCT,ACHSZFLC,ACHSZFNM,ACHSZFPT,ACHSZRC,ACHSZZ,DIC,DIR,X,Y,Z,X1,X2,ACHSZDEV,ACHSZFN,ACHSZFO,ACHSZIN,ACHSZZA
K ACHSSEQN,ACHSEDXT
K ^ACHSUSE("EOBR")
Q
;
ACHSEOBB ; IHS/ITSC/TPF/PMF - PROCESS EOBRS (2/6) CONTINUATION ;
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**21,22,23**;JUN 11, 2001;Build 43
+2 ;ACHS*3.1*22;FIXED SCC IN B RECORD;CHANGES FOR ALLOWING PROCESS OF ICD9 FILE FIX
+3 ;
+4 ; ACHS*3.1*23 9.19.13 IHS.OIT.FCJ CHANGED TO CHECK FOR RECORD "J" ICD-10 RECORDS
+5 ; ACHS*3.1*23 9.19.13 IHS.OIT.FCJ ADDED J REC, MODS TO G REC FIXED H REC
+6 ;
M1 ;EP
+1 ;
+2 ;IF CAME IN THRU OPTION ACHSFEOBR THEN PRINT CANCEL DOCUMENTS
+3 IF ACHSISAO
IF $$AOP^ACHS(2,6)="Y"
DO ^ACHSEOB2
+4 ;
+5 ;IF 'UPDATE DOCUMENT FROM EOBR' = YES THEN CALL UPDATE DOCUMENT
+6 ;DOES THIS REALLY SWITCH DUZ(2)'S - yes it does. pmf
+7 IF 'ACHSISAO
IF $$PARM^ACHS(2,15)="Y"
SET ACHSDUZ2=DUZ(2)
DO ^ACHSEOB3
SET ACHSYAYA=19
SET DUZ(2)=ACHSDUZ2
DO ^ACHSUF
KILL ACHSYAYA
+8 ;
+9 ;I 'PRINT EOBR'S' = YES PRINT EOBR SUMMARY REPORT
+10 ;I 'ACHSISAO,$$PARM^ACHS(2,14)="Y" D ^ACHSEOB2 ;ACHS*3.1*21
+11 ;
+12 ;A= HEADING A H=SUMMARY
+13 IF $EXTRACT(ACHSEOBR,19)'="A"!$EXTRACT(ACHSEOBR,19)'="H"!$EXTRACT(ACHSEOBR,1,2)'="**"
GOTO M1A
+14 USE IO(0)
+15 ;IF CHAR 19 NOT EQUAL TO 'A' OR 'H' OR FIRST TWO CHARS NOT '**' THEN ERROR??????
+16 WRITE *7,*7,!!,"LAST RECORD READ WAS OUT OF SEQUENCE",!!,"CONTACT YOUR SITEMANAGER - SEE ^ACHSEOBR(""SEQ-ERROR"").",!!
+17 ;CHAR 19 ERROR
SET ^ACHSEOBR("SEQ-ERROR")=ACHSEOBR
SET ACHSTERR=5
+18 QUIT
+19 ;
M1A ;
+1 IF $GET(ACHSEOBR("A",12))'=""
Begin DoDot:1
+2 SET ^ACHSEOBR("P",$EXTRACT(ACHSEOBR("A",12),2,12),ACHSCTR(1))=ACHSZFPT
+3 SET ACHSOLD=$EXTRACT(ACHSEOBR,1,18)
+4 SET X=ACHSEOBR
End DoDot:1
+5 KILL ^TMP("ACHSEOB",$JOB),ACHSEOBR,ACHSERRE
+6 SET ACHSEOBR=X
+7 QUIT
+8 ;
REC ;EP
+1 IF $LENGTH(ACHSEOBR)<80
SET ACHSEOBR=ACHSEOBR_$JUSTIFY("",80-$LENGTH(ACHSEOBR))
+2 ;I "ABCDEFGHI"'[$E(ACHSEOBR,19) U IO(0) W *7,!,"A Record was found that was not type 'A' thru 'I'.",!,"'",ACHSEOBR,"'" S ACHSTERR=10 Q
+3 ;ACHS*3.1*23
IF "ABCDEFGHIJ"'[$EXTRACT(ACHSEOBR,19)
USE IO(0)
WRITE *7,!,"A Record was found that was not type 'A' thru 'J'.",!,"'",ACHSEOBR,"'"
SET ACHSTERR=10
QUIT
+4 ;
PRT ;EP - From EOBR Error Report.
+1 ;DETAIL RECORD
+2 IF $EXTRACT(ACHSEOBR,19)="F"
DO REC1
SET ^TMP("ACHSEOB",$JOB,"F",+$EXTRACT(ACHSEOBR,20,22))=ACHSEOBR
DO GBLD^ACHSEOB1
QUIT
+3 ;
+4 ;PROCEDURES RECORD
+5 IF $EXTRACT(ACHSEOBR,19)="G"
SET ^TMP("ACHSEOB",$JOB,"G",+$EXTRACT(ACHSEOBR,20,22))=$EXTRACT(ACHSEOBR,23,65)
QUIT
+6 ;
REC1 ;EP - Set values of EOBR being processed into local array.
+1 DO REC2(ACHSEOBR,.ACHSEOBR)
+2 ;ACHS*3.1*23
SET ACHSREJ=$SELECT($DATA(ACHSEOBR("E")):"E",$DATA(ACHSEOBR("J")):"J",1:"")
+3 QUIT
+4 ;NEW SECTION OF CODE
REC2(ACHSREC,ACHSARRY) ;EP - DIVIDE A RECORD INTO ITS RESPECTIVE FIELDS
+1 ;
+2 NEW ACHS,ACHSRT,ACHSRL
+3 SET ACHSRT=$EXTRACT(ACHSREC,19)
+4 IF ACHSRT="C"
IF $EXTRACT(ACHSREC,20,22)="002"
SET ACHSRT="CA"
+5 ;ACHS*3.1*21
IF ACHSRT="H"
IF $EXTRACT(ACHSREC,20,22)="002"
SET ACHSRT="HA"
+6 ;ACHS*3.1*23
IF ACHSRT="G"
IF $$PARM^ACHS(0,17)
IF DT>($$PARM^ACHS(0,17)-1)
SET ACHSRT="G1"
+7 ;ACHS*3.1*23
IF ACHSRT="E"
IF $$PARM^ACHS(0,17)
IF DT>($$PARM^ACHS(0,17)-1)
SET ACHSRT="E1"
+8 ;ACHS*3.1*22 USE E1 ICD-CODE W DEC
IF ACHSRT="E"
IF $PIECE($GET(ACHSMEDA),".",2)="ICD"
SET ACHSRT="E1"
+9 SET ACHSRL=$TEXT(@ACHSRT)
+10 ;ACHS*3.1*23 NEW SECTION FOR PROCESSING "J" RECORD
+11 IF ACHSRT="J"
Begin DoDot:1
+12 ;TOTAL DX
SET ACHSRJCT=+$EXTRACT(ACHSREC,20,22)
SET ACHSEDXT=ACHSRJCT*3
+13 FOR ACHS=2:1
SET X=$PIECE(ACHSRL,";;",ACHS)
IF X=""
QUIT
Begin DoDot:2
+14 IF $PIECE(X,".",4)="S"
DO SIGN^ACHSEOB1
+15 IF ((ACHS=15)!(ACHS=16)!(ACHS=17))&(ACHSRJCT>1)
Begin DoDot:3
+16 SET ACHSARRY(ACHSRT,$PIECE(X+ACHSEDXT,"."))=$EXTRACT(ACHSREC,$PIECE(X,".",2),$PIECE(X,".",3))
End DoDot:3
QUIT
+17 SET ACHSARRY(ACHSRT,$PIECE(X,"."))=$EXTRACT(ACHSREC,$PIECE(X,".",2),$PIECE(X,".",3))
End DoDot:2
End DoDot:1
+18 ;REPLACED NXT 3 LINES WITH $S
+19 ;I ACHSRT="CA" S ACHSRT="C"
+20 ;I ACHSRT="HA" S ACHSRT="H" ;ACHS*3.1*21
+21 ;I ACHSRT="E1" S ACHSRT="E" ;ACHS*3.1*22 RESET VAR TO E
+22 SET ACHSRT=$SELECT(ACHSRT="CA":"C",ACHSRT="HA":"H",ACHSRT="E1":"E",ACHSRT="G1":"G",1:ACHSRT)
+23 FOR ACHS=2:1
SET X=$PIECE(ACHSRL,";;",ACHS)
IF X=""
QUIT
IF $PIECE(X,".",4)="S"
DO SIGN^ACHSEOB1
SET ACHSARRY(ACHSRT,$PIECE(X,"."))=$EXTRACT(ACHSREC,$PIECE(X,".",2),$PIECE(X,".",3))
+24 QUIT
+25 ;
+26 ; fld# . start_position . end_position . Sign ; See Tech Manual for rec layout
+27 ; Y2K changes
+28 ; TAG A CH: 11.46.51 TO 11.46.53 (CCYYMMDD)
+29 ; CH: 12.52.63 TO 12.54.65 -- SHIFTED
+30 ; CH: 13.64.70 TO 13.66.72 -- SHIFTED
+31 ; CH: 14.71.76 TO 14.73.78 -- SHIFTED
+32 ; CH: 15.77.78 TO 15.79.80 -- SHIFTED
A ;;1.1.2;;2.3.4;;3.5.6;;4.7.8;;5.9.18;;8.23.31;;9.32.38;;10.39.45;;11.46.53;;12.54.65;;13.66.72;;14.73.78;;15.79.80
+1 ;
+2 ; TAG B RECORD CHANGED ACHS*3.1*22
+3 ; 13.73.74;;14.75.78 TO 14.71.76
B ;;8.23.52;;9.53.59;;10.60.67;;11.68.69;;12.70.72;;14.73.76
+1 ;
+2 ; Y2K changes
+3 ; TAG C CH: 14.56.61 DROPPED
+4 ; CH: 15.62.67 DROPPED
+5 ; CH: 16.68.80 TO 16.56.68
C ;;8.23.38;;9.39.42;;10.43.43;;11.44.44;;12.45.54;;13.55.55;;16.56.68
+1 ;
CA ;;14.23.30;;15.31.38
+1 ;
D ;;8.23.52;;9.53.61.S;;10.62.70.S;;11.71.79.S
+1 ;
E ;;8.23.31.S;;9.32.32;;10.33.41.S;;11.42.50.S;;12.51.55;;13.56.60;;14.61.65;;15.66.70;;16.71.75
+1 ;ACHS*3.1*22 NEW E1 LINE TO READ IN DX CODE WITH DECIMAL USED FOR ICD9 FX
+2 ; CH: 12.51.55 to 12.51.56 -- SHIFTED
+3 ; CH: 13.56.60 to 13.57.62 -- SHIFTED
+4 ; CH: 14.61.65 to 14.63.68 -- SHIFTED
+5 ; CH: 15.66.70 to 15.69.74 -- SHIFTED
+6 ; CH: 16.71.75 to 16.75.80 -- SHIFTED
E1 ;;8.23.31.S;;9.32.32;;10.33.41.S;;11.42.50.S;;12.51.56;;13.57.62;;14.63.68;;15.69.74;;16.75.80
+1 ;
+2 ; Y2K changes
+3 ; TAG F ADD: 7.20.22
+4 ; CH: 8.23.28 TO 8.23.30 (CCYYMMDD)
+5 ; CH: 9.29.34 TO 9.31.38 (CCYYMMDD)
+6 ; CH: 10.35.39 TO 10.39.43 -- SHIFTED
+7 ; CH: 11.40.42 TO 11.44.46 -- SHIFTED
+8 ; CH: 12.43.51 TO 12.47.55 -- SHIFTED
+9 ; CH: 13.52.60 TO 13.56.64 -- SHIFTED
+10 ; CH: 14.61.64 TO 14.65.68 -- SHIFTED
+11 ; CH: 15.65.66 TO 15.69.70 -- SHIFTED
+12 ; CH: 16.67.71 TO 16.71.75 -- SHIFTED
F ;;7.20.22;;8.23.30;;9.31.38;;10.39.43;;11.44.46;;12.47.55.S;;13.56.64.S;;14.65.68;;15.69.70;;16.71.75
+1 ;
G ;;8.23.26;;9.27.30;;10.31.34
+1 ;
+2 ;ACHS*3.1*23 CHANGE TO THIS FOR ICD-10
G1 ;;8.23.29;;9.30.36;;10.37.43;11.44.50;12.51.57
+1 ;
+2 ; Y2K chsnges
+3 ; TAG H CH: 9.29.34 DROPPED
+4 ; CH: 10.35.40 DROPPED
+5 ; ADD: 16.66.70
H ;;1.1.2;;2.3.4;;4.7.8;;8.23.28;;11.41.45;;12.46.50;;13.51.55;;14.56.65.S;;16.66.70;;15.71.80.S
+1 ;
HA ;;9.23.30;;10.31.38
I ;;8.23.29;;9.30.33;;10.34.38.S;;11.39.41;;12.42.50.S;;13.51.56.S;;14.57.66.S
+1 ;
+2 ;ACHS*3.1*23 NEW J DX RECORD FOR ICD-10
J ;;8.23.31.S;;9.32.32;;10.33.41.S;;11.42.50.S;;12.51.58;;13.59.66;;14.67.74
+1 ;
+2 ;
AREA ;EP - Update Area parameter file after processing FI EOBR file.
+1 IF '$DATA(^ACHSAOP(DUZ(2),17,0))
SET ^ACHSAOP(DUZ(2),17,0)=$$ZEROTH^ACHS(9002079,17)
+2 SET DIC="^ACHSAOP("_DUZ(2)_",17,"
SET DA(1)=DUZ(2)
SET DIC(0)="LMN"
SET X=ACHSEOBD
SET DINUM=X
+3 KILL DD,DO
DO FILE^DICN
+4 IF +Y<1
USE IO(0)
WRITE !,*7,"UNABLE TO POST EOBR PROCESS DATE - NOTIFY SUPERVISOR",!,$$DIR^XBDIR("E","Enter <RETURN> to Continue")
+5 SET $PIECE(^ACHSAOP(DUZ(2),2),U,11)=ACHSEOBD
+6 ;S $P(^ACHSAOP(DUZ(2),2),U,9)=+$P(ACHSUFLS(ACHSFILE),U,5) ;ACHS*3.1*22
+7 ;ACHS*3.1*22;DO NOT SET IF ICD9 FILE
IF +ACHSAOSQ'=0
SET $PIECE(^ACHSAOP(DUZ(2),2),U,9)=+$PIECE(ACHSUFLS(ACHSFILE),U,5)
+8 IF +$PIECE(^ACHSAOP(DUZ(2),2),U,9)=999
SET $PIECE(^ACHSF(DUZ(2),2),U,9)=0
+9 IF ACHSMCNT>0
SET $PIECE(^ACHSAOP(DUZ(2),2),U,10)=DT
+10 IF '$LENGTH($$AOP^ACHS(2,7))
QUIT
+11 IF $$MV^%ZISH($$AOP^ACHS(2,1),ACHSMEDA,$$AOP^ACHS(2,7),ACHSMEDA)
WRITE !,*7,"Archive of '",$$AOP^ACHS(2,1),ACHSMEDA,"' to '",$$AOP^ACHS(2,7),ACHSMEDA,"' failed..."
IF 1
+12 IF '$TEST
WRITE !,"'",$$AOP^ACHS(2,1),ACHSMEDA,"' Archived to '",$$AOP^ACHS(2,7),ACHSMEDA,"'"
+13 ;ACHS*3.1*21 ADDED VAR FOR CONTINUING TO SPLIT OUT
SET ACHSISAC=1
+14 QUIT
+15 ;
FAC ;EP - Update CHS FACILITY with EOB Seq # and Process date.
+1 IF '$DATA(^ACHSF(DUZ(2),17,0))
SET ^ACHSF(DUZ(2),17,0)=$$ZEROTH^ACHS(9002080,17)
+2 SET DIC="^ACHSF("_DUZ(2)_",17,"
SET DIC(0)="LMN"
SET DA(1)=DUZ(2)
SET X=ACHSEOBD
SET DINUM=X
+3 KILL DD,DO
DO FILE^DICN
+4 SET $PIECE(^ACHSF(DUZ(2),2),U,21)=ACHSSEQN
+5 QUIT
+6 ;
FACSRCH ;EP
+1 KILL ACHSUFLS
+2 IF $$LIST^%ZISH($$IM^ACHS,ACHSMEDA_"*",.ACHSUFLS)
GOTO ABEND^ACHSEOB
+3 IF '$ORDER(ACHSUFLS(0))
QUIT
+4 SET ACHSUFLS=0
C01 ;
+1 SET ACHSUFLS=$ORDER(ACHSUFLS(ACHSUFLS))
+2 IF +ACHSUFLS=0
GOTO C0END
+3 SET Y=ACHSUFLS(ACHSUFLS)
+4 IF $$OS^ACHS=1
IF Y[".z"
Begin DoDot:1
+5 SET ACHSHCMD="unpack "_$$IM^ACHS_Y
+6 ;
+7 ;IHS/ITSC/PMF 1/12/01 change call of vendor routine to call
+8 ;of routine in our namespace.
+9 SET ACHSRTCD=$$TERMINAL^ACHSHCMD(ACHSHCMD)
+10 ;
+11 SET ACHSUFLS(ACHSUFLS)=$PIECE(Y,".z",1)
+12 QUIT
End DoDot:1
+13 ;
+14 IF $$OS^ACHS=1
IF Y[".Z"
Begin DoDot:1
+15 SET ACHSHCMD="uncompress "_$$IM^ACHS_Y
+16 ;
+17 ;IHS/ITSC/PMF 1/12/01 change call of vendor routine to call
+18 ;of routine in our namespace.
+19 SET ACHSRTCD=$$TERMINAL^ACHSHCMD(ACHSHCMD)
+20 ;
+21 SET ACHSUFLS(ACHSUFLS)=$PIECE(Y,".Z",1)
End DoDot:1
+22 ;
+23 IF $$OPEN^%ZISH($$IM^ACHS,ACHSUFLS(ACHSUFLS),"R")
GOTO ABEND^ACHSEOB
+24 USE IO
+25 ;SAC-FILE READ
READ X:DTIME
+26 IF '$TEST
GOTO ABEND^ACHSEOB
+27 DO ^%ZISC
+28 IF $EXTRACT(X,1,2)'="$$"
SET $PIECE(ACHSUFLS(ACHSUFLS)," ",5)="BAD"
GOTO C01
+29 SET ACHSUFLS(ACHSUFLS)=ACHSUFLS(ACHSUFLS)_" "_$PIECE(X,"$$",2)
+30 GOTO C01
+31 ;
C0END ;
+1 SET IONOFF=""
+2 DO ^%ZISC
+3 DO FILDEL^ACHSEOBC
C1 ;
+1 USE IO(0)
+2 WRITE !!," Files Available for Processing are Listed Below:",!?40,"Last Fac Seq # Processed = ",$JUSTIFY($$PARM^ACHS(2,21),5)
+3 WRITE !!?5,"Number",?15,"File Name",?45,"EOBR Proc Date",?65,"Fac Seq #",!?5,"------",?15,"----------------",?45,"--------------",?65,"---------"
+4 SET (ACHSI,ACHSJ,ACHSII)=0
C2 ;
+1 SET ACHSII=$ORDER(ACHSUFLS("C",ACHSII))
+2 IF +ACHSII=0
GOTO C5
+3 SET ACHSI=0
C3 ;
+1 SET ACHSI=$ORDER(ACHSUFLS("C",ACHSII,ACHSI))
+2 IF +ACHSI=0
GOTO C2
+3 SET ACHSJ=ACHSJ+1
SET ACHSK(ACHSJ)=ACHSI
+4 USE IO(0)
+5 WRITE !?5,$JUSTIFY(ACHSJ,3),?15,$PIECE(ACHSUFLS(ACHSK(ACHSJ))," ",1),?45,$$FMTE^XLFDT($PIECE(ACHSUFLS(ACHSK(ACHSJ))," ",2)),?67,$JUSTIFY(+$PIECE(ACHSUFLS(ACHSK(ACHSJ))," ",3),5)
+6 GOTO C3
+7 ;
C5 ;
+1 QUIT
+2 ;
KILL ;EP
+1 ;ACHS*3.1*21 REMOVED ACHSISAO
+2 KILL %MT,ACHSDIEN,ACHSCTR,ACHSDA,ACHSDERR,ACHSDOCR,ACHSDUZ2,ACHSEOBR,ACHSEOIO,ACHSMSG,ACHSOLD,ACHSTERR,ACHSTDA,DX,DY,ACHSMEDA,ACHSMEDY,ACHSSUF
+3 KILL ACHSDATE,ACHSDELD,ACHSDSAV,ACHSEBET,ACHSEOBD,ACHSERDT,ACHSERPT,ACHSERR,ACHSERRC,ACHSFILE,ACHSFNAM,ACHSFSIZ,ACHSHCMD
+4 KILL ACHSHFS1,ACHSI,ACHSII,ACHSISEQ,ACHSLCTR,ACHSLEOB,ACHSLMT,ACHSMCNT,ACHSMFLG,ACHSMSEQ,ACHSOMSG,ACHSPDT,ACHSPG,ACHSQUIT,ACHSR,ACHSRCT,ACHSRDAT,ACHSRPT,ACHSRR,ACHSSEL,ACHSTIME,ACHSUFLS
+5 KILL ACHSXX,ACHSZ3,ACHSZFCT,ACHSZFLC,ACHSZFNM,ACHSZFPT,ACHSZRC,ACHSZZ,DIC,DIR,X,Y,Z,X1,X2,ACHSZDEV,ACHSZFN,ACHSZFO,ACHSZIN,ACHSZZA
+6 KILL ACHSSEQN,ACHSEDXT
+7 KILL ^ACHSUSE("EOBR")
+8 QUIT
+9 ;
