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

ACHSEOBA.m

Go to the documentation of this file. 
  1. ACHSEOBA ; IHS/ITSC/TPF/PMF - SET ARRAY VARIABLES A THRU E FROM DOCUMENT FOR EOBR PRNTING ; JUL 10, 2008   
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**14,15,23,24**;JUN 11,2001;Build 43
  1.  ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES
  1.  ;3.1*15 1.22.2009 IHS/OIT/FCJ CSV CHANGES PRINTED INVALID CODES
  1.  ;
  1.  ;
  1.  S ACHSDOC=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,0),"NO DOC 0 RECORD")
  1.  S ACHSDOC3=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,3),"NO DOC 3 RECORD")
  1.  S ACHSTRAN=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0),"NO TRAN 0 RECORD")
  1.  S ACHSFAC0=$G(^ACHSF(DUZ(2),0),"NO CHS FACILITY 0 RECORD")
  1.  I $P(ACHSFAC0,U)'="" S ACHSLOC=$P(^AUTTLOC($P(ACHSFAC0,U),0),U,10) ;ASUFAC INDEX
  1.  E  S ACHSLOC="UNDEFINED"
  1.  K ^TMP("ACHSEOB",$J)
  1.  ;
  1.  ;THE A ARRAY
  1.  ;A HEADING RECORD
  1. A ;
  1.  F %=1:1:15 S ACHSEOBR("A",%)=""         ;INITIALIZE ARRAY
  1.  S ACHSEOBR("A",1)=$E(ACHSLOC,1,2)       ;AREA CODE
  1.  S ACHSEOBR("A",2)=$E(ACHSLOC,3,4)       ;SERVICE UNIT CODE
  1.  S ACHSEOBR("A",3)=$E(ACHSLOC,5,6)       ;FACILITY (CODE) NUMBER
  1.  S ACHSEOBR("A",4)="0"_$P(ACHSDOC,U,14)           ;FISCAL YEAR
  1.  S ACHSEOBR("A",5)=$E($P(ACHSTRAN,U,17),8,17)     ;EOBR CONTROL NUMBER
  1.                                                   ; PATTERN 7A-9N
  1.                                                   ;FI GENERATED   
  1.  S ACHSEOBR("A",6)="A"                            ;RECORD TYPE
  1.  ;S ACHEOBR("A",7)                                ;SEQ NUM ALWAYS 001?
  1.  S ACHSEOBR("A",8)=$P(ACHSTRAN,U,14)              ;EOBR CLAIM SEQ. NO.
  1.  S ACHSEOBR("A",9)=$P(ACHSTRAN,U,18)              ;CHECK #
  1.  S ACHSEOBR("A",10)=$P(ACHSTRAN,U,19)             ;EOBR REMITT. #
  1.  ;
  1.  ; change line.  store date as yyyymmdd.  050101  pmf   S ACHSEOBR("A",11)=$P(ACHSTRAN,U,13)
  1.  S ACHSEOBR("A",11)=$P(ACHSTRAN,U,13)+17000000    ;EOBR DATE
  1.  ; remove line.  05/01/01   pmf   S ACHSEOBR("A",11)=$E(ACHSEOBR("A",11),2,7)
  1.  ;
  1.  ;
  1.  ;BELOW IS PURCHASE ORDER # ; FISCAL YEAR-FACILITY?-ORDER NUMBER
  1.  S ACHSEOBR("A",12)=$P(ACHSDOC,U,14)_"-"_ACHSFC_"-"_$P(ACHSDOC,U)
  1.  S ACHSEOBR("A",13)=$E($P(ACHSTRAN,U,17),1,7) ;FIRST 7 OF CONTROL #
  1.  ;
  1.  ;BELOW IS FACILITY CODE     AREA CODE-SERVICE UNIT CODE-FACILITY CODE
  1.  S ACHSEOBR("A",14)=ACHSEOBR("A",1)_ACHSEOBR("A",2)_ACHSEOBR("A",3)
  1.  S ACHSEOBR("A",15)=$P(ACHSDOC,U,4)           ;TYPE OF SERV. (DOC. TYPE)
  1.  S ACHSEOBR("A",15)=$S(ACHSEOBR("A",15)=1:43,ACHSEOBR("A",15)=2:57,ACHSEOBR("A",15)=3:64)     ;
  1.  ;
  1.  ;THE B ARRAY
  1.  ;B HEADING RECORD
  1. B ;
  1.  F %=8:1:14 S ACHSEOBR("B",%)=""      ;INITIALIZE ARRAY
  1.  S %=$P(ACHSDOC,U,22)                      ;GET PATIENT PTR
  1.  I % S ACHSEOBR("B",8)=$P($G(^DPT(%,0)),U) ;GET PATIENT NAME
  1.  E  S ACHSEOBR("B",8)=$S($P(ACHSDOC,U,3)=1:"* BLANKET",$P(ACHSDOC,U,3)=2:"* SPECIAL TRANS",1:"")
  1.  S ACHSEOBR("B",9)=$P(ACHSDOC,U,21)          ;HRN HEALTH REC #
  1.  S ACHSEOBR("B",10)=17000000+$P(ACHSDOC,U,2) ;AUTH DATE CCYYMMDD
  1.  S ACHSEOBR("B",11)=$P(ACHSTRAN,U,9)         ;WORKLOAD  (ACTUAL DAYS)
  1.  ;
  1.  S %=$$DOC^ACHS(8,1)                         ;GET DRG PTR
  1.  I % S %="00"_%,ACHSEOBR("B",12)=$E(%,$L(%)-2,$L(%))
  1.  S %=$$DOC^ACHS(8,4)                         ;GET DISCHARGE TYPE
  1.  I % S ACHSEOBR("B",13)=$P($G(^DIC(42.2,%,9999999)),U) ;IHS CODE(FILLER)
  1.  ;BELOW IS: USE OBJECT CLASSIFICATION PTR, GET OBJ CLASS CODE 
  1.  I $P(ACHSDOC,U,7) S ACHSEOBR("B",14)=$P($G(^ACHS(3,DUZ(2),1,$P(ACHSDOC,U,7),0)),U)
  1.  E  S ACHSEOBR("B",14)=""
  1.  ;
  1.  ;THE C ARRAY
  1.  ;C HEADING RECORD
  1. C ;
  1.  F %=8:1:16 S ACHSEOBR("C",%)=""       ;INITIALIZE ARRAY
  1.  I $P(ACHSDOC,U,6) S ACHSEOBR("C",8)=$P(^ACHS(2,$P(ACHSDOC,U,6),0),U)    ;CAN PTR TO CAN 
  1.  E  S ACHSEOBR("C",8)="XXXXXXXXXXXXXXXX"
  1.  ;S ACHSEOBR("C",9)=$P($G(^ACHSOCC($P(ACHSDOC,U,10),0)),U)  ;VENDOR CHARGE EST TO GET OBJECT CLASS CODE???????
  1.  ;GET OBJECT CLASS PTR THEN OBJECT CLASS CODE
  1.  I $P(ACHSDOC,U,7) S ACHSEOBR("C",9)=$P($G(^ACHSOCC($P(ACHSDOC,U,7),0)),U)
  1.  E  S ACHSEOBR("C",9)="UNKN"
  1.  S ACHSEOBR("C",10)=$P(ACHSTRAN,U,20)   ;EOBR SERVICES BILLED  
  1.  S ACHSEOBR("C",11)=$P(ACHSDOC,U,3)     ;BLANKET ORDER (INDICATOR)
  1.  S ACHSEOBR("C",11)=$S(ACHSEOBR("C",11)=1:"Y",ACHSEOBR("C",11)=0:"N",1:"")
  1.  S ACHSEOBR("C",12)="OM"                ;(CONTRACT NUMBER) ?????
  1.  ;
  1.  ;IF CON. PTR AND VEND. PTR GET CON. # FROM VEND. CONTRACT FILE 
  1.  S ACHSVEND=$P(ACHSDOC,U,8)
  1.  I $P(ACHSDOC,U,5),ACHSVEND S ACHSEOBR("C",12)=$P(^AUTTVNDR($P(ACHSDOC,U,8),"CN",$P(ACHSDOC,U,5),0),U)
  1.  E  S ACHSEOBR("C",12)="OM"
  1.  ;
  1.  ;
  1.  ;
  1.  S ACHSEOBR("C",13)=$P(ACHSTRAN,U,15)  ;EOBR PAY TYPE (INTERM/FINAL IND)
  1.  ;
  1.  S ACHSEOBR("C",14)=17000000+$P(ACHSDOC3,U)   ;AUTH BEGIN DATE (SERV START DATE
  1.  S ACHSEOBR("C",15)=17000000+$P(ACHSDOC3,U,2) ;AUTH ENDING DATE (SERV END DATE)
  1.  ;
  1.  ;GET VENDOR PTR
  1.  I ACHSVEND D
  1.  .I $D(^AUTTVNDR(ACHSVEND,11)) D
  1.  ..S ACHSEOBR("C",16)=$P(^AUTTVNDR(ACHSVEND,11),U)    ;'EIN NO.'
  1.  ..;BELOW GET EIN SUFFIX AND SLAP IT ON END OF EIN NO
  1.  ..I $P(^AUTTVNDR(ACHSVEND,11),U,2)'="" S ACHSEOBR("C",16)=ACHSEOBR("C",16)_"-"_$P(^AUTTVNDR(ACHSVEND,11),U,2)     ;
  1.  ;
  1.  ;D ARRAY
  1.  ;D HEADING RECORD
  1.  ;
  1. D ;
  1.  F %=8:1:11 S ACHSEOBR("D",%)=""    ;INIT ARRAY
  1.  S ACHSEOBR("D",8)=$P($G(^AUTTVNDR(ACHSVEND,0)),U)  ;VENDOR NAME
  1.  S ACHSEOBR("D",11)=$P(ACHSTRAN,U,8)                ;THIRD PART. PAY AMT
  1.  S ACHSEOBR("D",9)=0                                ;BILLED BY PROV.
  1.  S ACHSEOBR("D",10)=0                               ;ALLOWABLE AMT
  1.  ;
  1.  ;BELOW FORMATS OUT THE DECIMAL FOR MAINFRAME PROGRAM
  1.  I ACHSEOBR("D",11)["." S %=ACHSEOBR("D",11),%=$P(%,".")_$E($P(%,".",2)_"00",1,2),ACHSEOBR("D",11)=%
  1.  E  S ACHSEOBR("D",11)=ACHSEOBR("D",11)_"00"
  1.  ;
  1. I ; Interest info.
  1.  S DA(2)=DUZ(2),DA(1)=ACHSDIEN,DA=ACHSTIEN
  1.  ;BELOW SETS UP I ARRAY FROM 8 TO 14
  1.  ;BY GETTING THE VALUES IN FIELDS 22- 28 FROM THE TRANSACTION SUBFILE OF
  1.  ;THE CHS FACILITY  CAN WE SIMPLIFY THIS?????
  1.  ;ACHSEOBR("I",8)=INTEREST CAN
  1.  ;             9)=INTEREST OBJECT CLASS CODE
  1.  ;            10)=INTEREST RATE
  1.  ;            11)=INTEREST DAYS ELIGIBLE
  1.  ;            12)=INTEREST PAID
  1.  ;            13)=INTEREST ADDTNL PENALTY PAID
  1.  ;            14)=INTEREST TOTAL PAID THIS TRANS 
  1.  F ACHS=22:1:28 S ACHSEOBR("I",ACHS-14)=$$VAL^XBDIQ1(9002080.02,.DA,ACHS)
  1.  ;BELOW FORMATS: INTEREST OBJECT CLASS CODE
  1.  S ACHSEOBR("I",9)=$P(ACHSEOBR("I",9),".")_$P(ACHSEOBR("I",9),".",2)
  1.  ;
  1.  ;E OR J ARRAY
  1.  ;E OR J HEADING RECORD
  1.  ;ACHS*3.1*23 CHG "E" TO VAR ACHSREJ FOR REC E OR J
  1. E ;
  1.  S:'$G(ACHSREJ) ACHSREJ="J"  ;ACHS*3.1*24
  1.  F %=8:1:16 S ACHSEOBR(ACHSREJ,%)=""        ;INIT ARRAY
  1.  S ACHSEOBR(ACHSREJ,8)=$P(ACHSTRAN,U,4)     ;IHS PAYMENT AMOUNT
  1.  S ACHSEOBR(ACHSREJ,9)=$P(ACHSTRAN,U,21)    ;EOBR OBLIGATION TYPE
  1.  ;FORMAT THE DECIMAL OUT FOR MAINFRAME
  1.  I ACHSEOBR(ACHSREJ,8)["." S %=ACHSEOBR(ACHSREJ,8),%=$P(%,".")_$E($P(%,".",2)_"00",1,2),ACHSEOBR(ACHSREJ,8)=%
  1.  E  S ACHSEOBR(ACHSREJ,8)=ACHSEOBR(ACHSREJ,8)_"00"
  1.  ;
  1.  ;
  1.  ;BELOW: GO THRU DIAGNOSIS MULTIPLE AND PULL
  1.  ;THIS IS A REWRITE OF A GO LOOP
  1.  ;THERE MAY BE A PROBLEM IN THE LOGIC OF THIS I FOUND PIECE 2 
  1.  ;RARELY POPULATED  
  1. E1 S ACHSCNTR=11    ;INIT COUNTER FOR DIAG FIELD NUMBERS FOR MAINFRAME 
  1.  S ACHSICD=0
  1.  F  S ACHSICD=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHSICD)) Q:+ACHSICD=0  D
  1.  .Q:$G(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHSICD,0))=""
  1.  .;GET DIAGNOSIS ZERO NODE RECORD
  1.  .S ACHSICD0=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHSICD,0))
  1.  .;IF WE HAVE AN ICD CODE AND A EOBR TRANSACTION NUMBER
  1.  .I $P(ACHSICD0,U),$P(ACHSICD0,U,2) D
  1.  ..S ACHSCNTR=ACHSCNTR+1
  1.  ..S ACHSEOBR(ACHSREJ,ACHSCNTR)=$P(ACHSICD0,U)
  1.  ..;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES
  1.  ..;3.1*15 1.22.2009 IHS/OIT/FCJ CSV CHANGES PRINTED INVALID CODES
  1.  ..;S ACHSEOBR("E",ACHSCNTR)=$P($G(^ICD9($P(ACHSICD0,U),0)),U)
  1.  ..;ACHS*3.1*23
  1.  ..;S ACHSEOBR(ACHSREJ,ACHSCNTR)=$P($$ICDDX^ICDCODE($P(ACHSICD0,U),0),U,2)
  1.  ..S ACHSEOBR(ACHSREJ,ACHSCNTR)=$P($$ICDDX^ICDEX($P(ACHSICD0,U),,,"I"),U,2)
  1.  ;
  1.  ;
  1.  D ^ACHSEOBF   ; GO DO MORE ARRAY VARIABLES F AND G FOR EOBR
  1.  Q
  1.  ;
  1.  ;