Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACHSEOBB

ACHSEOBB.m

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