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

ACHSTX7.m

Go to the documentation of this file. 
  1. ACHSTX7 ;IHS/ITSC/PMF - EXPORT DATA (8/9) - RECORD 7(638 STATISTICAL DATA FOR NPIRS) ;JUL 10, 2008
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**2,3,5,7,11,12,14,15,21,23**;JUN 11,2001;Build 43
  1.  ;ACHS*3.1*2; add missing FOR loop
  1.  ;ACHS*3.1*3  Add UID number to type 7 transaction
  1.  ;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Add AGE to Dental 638.
  1.  ;This routine is done during the export process.  It creates
  1.  ;type 7 records, if the conditions are right.
  1.  ;The conditions for a type 7 record are:
  1.  ;   1) A document is destined for the IHS, not the FI, and
  1.  ;   2) the document has been PAID since the last time 
  1.  ;      export was done.
  1.  ;ACHS*3.1*7  Add Service Class Code to type 7 transaction
  1.  ;ITSC/SET/JVK ACHS*3.1*11 Send additional info for export
  1.  ;;ACHS*3.1*14 IHS/OIT/FCJ CHANGE IN THE UNIQUE REG ID to 15
  1.  ;ACHS*3.1*15 IHS/OIT/FCJ ADDED LINE FOR BEG REC DT ACHSFDT
  1.  ;
  1.  ;
  1.  ;IHS/ITSC/PMF  
  1.  ;     changes made in response to NOIS call XJG-0600-160027
  1.  ;     the ACHSTXPG global points to a patient who is not in ^DPT.
  1.  ;     instead of bombing, we will skip that document, only
  1.  ;     because we don't have any better ideas - yet.
  1.  ;     STRUCTURAL changes are being made at the same time to
  1.  ;     reduce the amount of spaghetti in the way.
  1.  ;
  1.  ;if we have records to look at, then do so
  1.  I $O(^ACHSTXPG(0))'="" D GOTSOME
  1.  ;
  1.  ;done.  clean up and get out
  1.  K ACHSADDT,ACHSAPC,ACHSAUTH,ACHSCOMM,ACHSDATA,ACHSDIDT,ACHSDIEN
  1.  K ACHSDITY,ACHSDX,ACHSEIN,ACHSTOS,ACHSIPA,ACHSFULP,ACHSLOS,ACHSPX
  1.  K ACHSTRAN,ACHSTRIB,ACHSX,ACHSY,ACHSAGID,ACHSFDTT ;ACHS*3.1*14 IHS/OIT/FCJ ADDDED ACHSAGID VAR
  1.  S ACHSROUT=ACHSRCT
  1.  ;
  1.  K DOLH,PMFCOUNT
  1.  ;
  1.  G ^ACHSTX8
  1.  ;
  1.  ;
  1. GOTSOME ;
  1.  ;this is the central loop of the program.
  1.  ;For each document listed, see if it qualifies to create a record
  1.  ;
  1.  ;ACHS*3.1*21;ADDED PARM TEST TO NEXT LINE
  1.  I $G(ACHSFDTT),$$PARM^ACHS(2,11)'="Y" S ACHSFDT=ACHSFDTT ;ACHS*3.1*15 AND 16 IHS.OIT.FCJ Added test for re-export opt
  1.  W !!?10,"BUILDING ",$$REC^ACHSACO1(7)," : ",!?9
  1.  ;
  1.  S ACHSTOS=0 F  S ACHSTOS=$O(^ACHSTXPG(ACHSTOS)) Q:'ACHSTOS  D
  1.  . ;12/21/01  pmf  add a F to the next line ACHS*3.1*2
  1.  . ;S ACHSDIEN="" S ACHSDIEN=$O(^ACHSTXPG(ACHSTOS,ACHSDIEN)) Q:'ACHSDIEN  D  ; ACHS*3.1*2
  1.  . S ACHSDIEN="" F  S ACHSDIEN=$O(^ACHSTXPG(ACHSTOS,ACHSDIEN)) Q:'ACHSDIEN  D  ; ACHS*3.1*2
  1.  ..; S DA=0 F  S DA=$O(^ACHSTXPG(ACHSTOS,ACHSDIEN,DA)) Q:'DA  D PROC
  1.  ..S XDA=0 F  S XDA=$O(^ACHSTXPG(ACHSTOS,ACHSDIEN,XDA)) Q:'XDA  S DA=XDA D PROC
  1.  .. Q
  1.  . Q
  1.  Q
  1.  ;
  1. PROC ;
  1.  ;now that we have a DA under this DIEN, under this TOS, process it
  1.  S ACHSDOCR=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,0))
  1.  S ACHSTRAN=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",DA,0))
  1.  I $P(ACHSTRAN,U,2)'="P" Q
  1.  S DFN=$P(ACHSDOCR,U,22)
  1.  I +DFN=0 Q
  1.  ;
  1.  ;here is the new code to support nois call XJG-0600-160027
  1.  I $G(^DPT(DFN,0))="" Q
  1.  ;
  1.  ;If we got this far, we PROBABLY have a record to write,
  1.  ;so fetch more info on the patient, and extract and format
  1.  ;info about the patient and about the document
  1.  ;
  1.  S ACHSSEX=$S($P(^DPT(DFN,0),U,2)="F":2,1:1),%=$P(^(0),U,3),ACHSDOB=17000000+%
  1.  S ACHSX=$P(ACHSDOCR,U,14)
  1.  D FYCVT^ACHSFU
  1.  ;
  1.  S ACHSAUTH=$E(ACHSY,3,4)_$E(+$P(ACHSDOCR,U)+100000,2,6)
  1.  S ACHSHRN=$$HRN^ACHS(DFN,DUZ(2)),ACHSHRN=$E(1000000+ACHSHRN,2,7)
  1.  S ACHSSSN=$E($$SSN^AUPNPAT(DFN)_$J("",9),1,9)
  1.  D TRIB^ACHSTX8
  1.  S ACHSCOMM=$J("",7)
  1.  I $P(^AUPNPAT(DFN,11),U,18)]"",$D(^AUTTCOM("B",$P(^(11),U,18))) S %=$P(^AUTTCOM($O(^AUTTCOM("B",$P(^AUPNPAT(DFN,11),U,18),0)),0),U,8),ACHSCOMM=$E(%,5,7)_$E(%,3,4)_$E(%,1,2)
  1. PTYP ;
  1.  S ACHSPTYP=$J("",2)
  1.  I $P(^AUTTVNDR($P(ACHSDOCR,U,8),11),U,3) S ACHSPTYP=$P(^AUTTVTYP($P(^(11),U,3),0),U),ACHSPTYP=$E(ACHSPTYP_"  ",1,2)
  1.  ;
  1.  S ACHSEIN=$E($P(^AUTTVNDR($P(ACHSDOCR,U,8),11),U)_$J("",10),1,10)
  1.  S ACHSIPA=$J("",8)
  1.  I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")) S ACHSIPA=+$P(^("PA"),U)
  1.  S ACHSIPA=$P(ACHSIPA,".")_$E($P(ACHSIPA,".",2)_"00",1,2),ACHSIPA=$E(100000000+ACHSIPA,2,9)
  1.  ;ITSC/SET/JVK ACHS*3.1*11 Third party corrdination of bens, nxt 3 lns.
  1.  S ACHSZPA=$J("",8)
  1.  I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")) S ACHSZPA=+$P(^("PA"),U,5)
  1.  S ACHSZPA=$P(ACHSZPA,".")_$E($P(ACHSZPA,".",2)_"00",1,2),ACHSZPA=$E(100000000+ACHSZPA,2,9)
  1.  ;
  1.  ;mostly done extracting and formatting.  now split the process
  1.  ;based on type of service.
  1.  ;We may still not write a record if this is an outside
  1.  ;service (64), and we do not have at least one procedure
  1.  ;code ( ACHSAPC(1) must be a procedure code number )
  1.  ;
  1.  ;get the type of service into ACHSTOS2
  1.  ;43 = inpatient,  57 = dental,  64 = outpatient
  1.  D TOS^ACHSTX8
  1.  ;
  1.  ;ITSC/SET/JVK ACHS*3.1*7 Code for NPIRS to get SCC NXT 2 LINES
  1.  S ACHSSCC=$P(ACHSDOCR,U,7)
  1.  S ACHSSCC=$P(^ACHS(3,DUZ(2),1,ACHSSCC,0),U)
  1.  ;
  1.  ;ITSC/SET/JVK ACHS*3.1*11 Add payment destination,order date,payment date 
  1.  S ACHSPDST=$P(ACHSDOCR,U,17)
  1.  S %=$P(ACHSDOCR,U,2),%=$J(%,"",8),ACHSODT=17000000+%,ACHSODT=$E(ACHSODT,1,4)_$E(ACHSODT,5,6)_$E(ACHSODT,7,8)
  1.  I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")) S %=$J("",8),%=$P(^("PA"),U,3),ACHSPDT=17000000+%,ACHSPDT=$E(ACHSPDT,1,4)_$E(ACHSPDT,5,6)_$E(ACHSPDT,7,8)
  1.  ;
  1.  ;handle each type of service differently.  dental first
  1.  I ACHSTOS2=57 D 57 Q
  1.  ;
  1.  ;set up some data before other service types
  1.  S ACHSFULP=$S($P(ACHSTRAN,U,5)="P":2,1:1)
  1.  ;ITSC/SET/JVK ACHS*3.1*11 ADD PAYMENT DESTINATION TO LINE
  1.  ;S ACHSDATA=ACHSAUTH_ACHSHRN_ACHSSSN_ACHSDOB_ACHSSEX_ACHSTRIB_"   "_ACHSCOMM_ACHSAFAC_ACHSPTYP_ACHSEIN
  1.  S ACHSDATA=ACHSAUTH_ACHSHRN_ACHSSSN_ACHSDOB_ACHSSEX_ACHSTRIB_ACHSPDST_"  "_ACHSCOMM_ACHSAFAC_ACHSPTYP_ACHSEIN
  1.  D DXPX^ACHSTX7A
  1.  ;
  1.  I ACHSTOS2=43 D 43
  1.  I ACHSTOS2=64,(+ACHSAPC(1)>0) D 64
  1.  Q
  1.  ;
  1. 43 ;inpatient service processed here
  1.  S ACHSADDT=$J("",8)
  1.  ;
  1.  I $P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,8)),U,2) S %=$P(^(8),U,2),ACHSADDT=17000000+%
  1.  ;
  1.  I +ACHSADDT<1 Q
  1.  S ACHSDIDT=$J("",8)
  1.  I $P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,8)),U,3) S %=$P(^(8),U,3),ACHSDIDT=17000000+%
  1.  ;
  1.  S DA(1)=DUZ(2),DA=ACHSDIEN
  1.  Q:$$VAL^XBDIQ1(9002080.01,.DA,93)<0  ;ACHS*3.1*23 TST FOR ADM<DSCHG
  1.  S ACHSLOS=$E(1000+$$VAL^XBDIQ1(9002080.01,.DA,93),2,4)
  1.  ;
  1.  S ACHSDITY=$S($P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,8)),U,4):$P(^(8),U,4),1:1),ACHSDITY=$S($D(^DIC(42.2,ACHSDITY,9999999)):$P(^(9999999),U),1:1)
  1.  ;ACHS*3.1*23 TEST FOR ICD10 CHANGE
  1.  ;D ICD
  1.  D @$S((DT<$$PARM^ACHS(0,18)):"ICD",1:"ICD10")
  1.  ;ITSC/SET/JVK ACHS*3.1*7 ADD ACHSSCC TO DATA LINE
  1.  ;S ACHSDATA=19_ACHSDATA_ACHSADDT_ACHSDIDT_ACHSLOS_ACHSDITY_ACHSDX(1)_ACHSDX(2)_ACHSDX(3)_ACHSDX(4)_ACHSDX(5)_ACHSPX(1)_"    "_ACHSPX(2)_ACHSPX(3)_"          "_ACHSRCOI_ACHSINJP_ACHSIPA_ACHSFULP
  1.  ;ITSC/SET/JVK ACHS*3.1*11 ADD ISSUE AND PAYMENT DATE
  1.  ;S ACHSDATA=19_ACHSDATA_ACHSADDT_ACHSDIDT_ACHSLOS_ACHSDITY_ACHSDX(1)_ACHSDX(2)_ACHSDX(3)_ACHSDX(4)_ACHSDX(5)_ACHSPX(1)_"    "_ACHSPX(2)_ACHSPX(3)_"          "_ACHSRCOI_ACHSINJP_ACHSIPA_ACHSFULP_ACHSSCC
  1.  ;ACHS*3.1*23 REWROTE SECTION FOR ICD10 RECORD
  1.  D @$S((DT<$$PARM^ACHS(0,18)):"ICD943",1:"ICD1043")
  1.  D 43RE
  1.  Q
  1. ICD943 ;43-ICD9 RECORD
  1.  S ACHSDATA=19_ACHSDATA_ACHSADDT_ACHSDIDT_ACHSLOS_ACHSDITY_ACHSDX(1)_ACHSDX(2)_ACHSDX(3)_ACHSDX(4)_ACHSDX(5)_ACHSPX(1)_"    "_ACHSPX(2)_ACHSPX(3)_"          "_ACHSRCOI_ACHSINJP_ACHSIPA_ACHSFULP_ACHSSCC_"  "
  1.  S ACHSDATA=ACHSDATA_ACHSODT_ACHSPDT_"   "_ACHSZPA_ACHSDX(6)_ACHSDX(7)_ACHSDX(8)_ACHSDX(9)_" "
  1.  Q
  1.  ;
  1. ICD1043 ;43-ICD10 RCORD
  1.  S ACHSDATA=19_ACHSDATA_ACHSADDT_ACHSDIDT_ACHSLOS_ACHSDITY_ACHSDX(1)_ACHSDX(2)_ACHSDX(3)_ACHSDX(4)_ACHSDX(5)_ACHSDX(6)_$J("",7)_ACHSINJP_ACHSIPA_ACHSFULP_ACHSSCC_"  "
  1.  S ACHSDATA=ACHSDATA_ACHSODT_ACHSPDT_"   "_ACHSZPA_ACHSPX(1)_ACHSPX(2)_ACHSPX(3)
  1.  Q
  1.  ;
  1. 43RE ;END OF 43 RECORD
  1.  S ACHS=$$REV^ACHSTX7A(DUZ(2),ACHSDIEN)
  1.  S ACHSDATA=ACHSDATA_$P(ACHS,U)_$P(ACHS,U,3)_$P(ACHS,U,2)_$J("",30)
  1.  S ACHS=$$CPT^ACHSTX7A(DUZ(2),ACHSDIEN)
  1.  S ACHSDATA=ACHSDATA_"  "_$P(ACHS,U)_$P(ACHS,U,3)_$P(ACHS,U,2)_$J("",30)
  1.  D ENDREC
  1.  Q
  1.  ;
  1. 57 ;dental service processed here
  1.  S ACHS=$$ADA^ACHSTX7A(DUZ(2),ACHSDIEN)
  1.  ;
  1.  S ACHSDATA=25_$P(^AUTTLOC(DUZ(2),0),U,10)_$E(ACHSEIN,2,10)_$S(ACHSSEX=1:"M",1:"F")_ACHSDOB_ACHSSSN_$P(ACHS,U)_$P(ACHS,U,2)_$S($P(ACHSTRAN,U,10):17000000+$P(ACHSTRAN,U,10),1:$J("",8))
  1.  ;S ACHSDATA=ACHSDATA_$J("",34)_$P(ACHS,U,3);IHS/SET/GTH ACHS*3.1*5 12/06/2002
  1.  ;ITSC/SET/JVK ACHS*3.1*11 ADD PAYMT DESTINATION
  1.  ;S %="00"_$$AGE^AUPNPAT(DFN),%=$E(%,($L(%)-1),$L(%)),ACHSDATA=ACHSDATA_$J("",32)_%_$P(ACHS,U,3) ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
  1.  S %="00"_$$AGE^AUPNPAT(DFN),%=$E(%,($L(%)-1),$L(%)),ACHSDATA=ACHSDATA_$J("",18)_ACHSAUTH_ACHSHRN_ACHSPDST_%_$P(ACHS,U,3) ;IHS/SET/ACHS*3.1*11 
  1.  ;ITSC/SET/JVK 11/10/2003 --FOR DENTAL
  1.  ;S ACHSDATA=ACHSDATA_ACHSSCC
  1.  ;ITSC/SET/JVK ACHS*3.1*11 ADD ORDER DATE
  1.  S ACHSDATA=ACHSDATA_ACHSSCC_ACHSODT_ACHSPDT_ACHSZPA_"  "
  1.  ;
  1.  D ENDREC
  1.  Q
  1.  ;
  1. 64 ;
  1.  S ACHSHONN=$J("",7)
  1.  I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,2)),$P(^(2),U),$D(^ACHSF(DUZ(2),"D",$P(^(2),U),0)) S ACHSX=$P(^(0),U,14),ACHSHONN=$P(^(0),U) D FYCVT^ACHSFU S ACHSHONN=$E(ACHSY,3,4)_ACHSHONN
  1.  S ACHSDOS=$J("",8)
  1.  I $P(ACHSTRAN,U,10) S %=$P(ACHSTRAN,U,10),ACHSDOS=17000000+%
  1.  S ACHSIPA=$E(ACHSIPA,3,8),%=$P(ACHSTRAN,U,9),ACHSVST=$E(100+%,2,3)
  1.  ;
  1.  ;ACHS*3.1*23 TEST FOR ICD10 CHANGE
  1.  ;D ICD
  1.  D @$S((DT<$$PARM^ACHS(0,18)):"ICD",1:"ICD10")
  1.  ;
  1.  ;ITSC/SET/JVK ACHS*3.1*7 ADD ACHSSCC TO DATA LINE
  1.  ;S ACHSDATA=20_ACHSDATA_ACHSHONN_ACHSDOS_2_ACHSAPC(1)_$S(ACHSAPC(1)="   ":" ",1:1)_ACHSAPC(2)_$S(ACHSAPC(2)="   ":" ",1:1)_ACHSVST_ACHSIPA_$J("",13)_ACHSFULP_ACHSPX(1)
  1.  ;ACHS*3.1*23 REWROTE SECTION FOR ICD10 RECORD
  1.  D @$S((DT<$$PARM^ACHS(0,18)):"ICD964",1:"ICD1064")
  1.  D 64RE
  1.  Q
  1. ICD964 ;BEFORE ICD10 IMPLEMENTATION
  1.  S ACHSDATA=20_ACHSDATA_ACHSHONN_ACHSDOS_2_ACHSAPC(1)_$S(ACHSAPC(1)="   ":" ",1:1)_ACHSAPC(2)_$S(ACHSAPC(2)="   ":" ",1:1)_ACHSVST_ACHSIPA_$J("",13)_ACHSFULP_ACHSPX(1)_ACHSSCC_ACHSODT_ACHSPDT_$J("",4)_ACHSZPA
  1.  S ACHSDATA=ACHSDATA_ACHSDX(1)_ACHSDX(2)_ACHSDX(3)_ACHSDX(4)_ACHSDX(5)_ACHSDX(6)_ACHSDX(7)_ACHSDX(8)_ACHSDX(9)_"  "
  1.  Q
  1.  ;
  1. ICD1064 ;AFTER ICD10 IMPLEMENTATION
  1.  S ACHSDATA=20_ACHSDATA_ACHSHONN_ACHSDOS_2_ACHSAPC(1)_$S(ACHSAPC(1)="   ":" ",1:1)_ACHSAPC(2)_$S(ACHSAPC(2)="   ":" ",1:1)_ACHSVST_ACHSIPA_$J("",13)_ACHSFULP_$J("",4)_ACHSSCC_ACHSODT_ACHSPDT_$J("",4)_ACHSZPA
  1.  S ACHSDATA=ACHSDATA_ACHSDX(1)_ACHSDX(2)_ACHSDX(3)_ACHSDX(4)_ACHSDX(5)_$J("",7)
  1.  Q
  1.  ;
  1. 64RE ;END RECORD
  1.  S ACHS=$$CPT^ACHSTX7A(DUZ(2),ACHSDIEN)
  1.  S ACHSDATA=ACHSDATA_$P(ACHS,U)_$P(ACHS,U,3)_$P(ACHS,U,2)_$J("",31)
  1.  D ENDREC
  1.  Q
  1.  ;
  1. ENDREC ;do the end of the record here, for all types of service
  1.  S ACHSDATA=ACHSDATA_$J("",162-$L(ACHSDATA))
  1.  S ACHSRCT=ACHSRCT+1,^ACHSDATA(ACHSRCT)="7A"_$E(ACHSDATA,1,78),ACHSRTYP(7)=ACHSRTYP(7)+1
  1.  S ACHSRCT=ACHSRCT+1,^ACHSDATA(ACHSRCT)="7B"_$E(ACHSDATA,79,156),ACHSRTYP(7)=ACHSRTYP(7)+1
  1.  S ACHSRCT=ACHSRCT+1,^ACHSDATA(ACHSRCT)="7C"_$E(ACHSDATA,157,234),ACHSRTYP(7)=ACHSRTYP(7)+1
  1.  ;ITSC/SET/JVK ACHS*3.1*11
  1.  ;I ACHSTOS2'=57 S ACHSRCT=ACHSRCT+1,^ACHSDATA(ACHSRCT)="7C"_$E(ACHSDATA,157,234),ACHSRTYP(7)=ACHSRTYP(7)+1
  1.  ;I ACHSTOS2=57 S ACHSRCT=ACHSRCT+1,^ACHSDATA(ACHSRCT)="7C"_$E(ACHSDATA,157,234),ACHSRTYP(7)=ACHSRTYP(7)+1
  1.  ;
  1.  ;12/27/01  pmf  add universal id number as record 7d
  1.  ;S ACHSRCT=ACHSRCT+1,^ACHSDATA(ACHSRCT)="7D"_$$UID^AGTXID(DFN)_$J(ACHSDIEN,20),$J("",41),ACHSRTYP(7)=ACHSRTYP(7)+1  ; ACHS*3.1*3
  1.  I ACHSTOS2'=57 S ACHSRCT=ACHSRCT+1,^ACHSDATA(ACHSRCT)="7D"_$E(ACHSDATA,235,312),ACHSRTYP(7)=ACHSRTYP(7)+1
  1.  I ACHSTOS2'=57 S ACHSRCT=ACHSRCT+1,^ACHSDATA(ACHSRCT)="7E"_$E(ACHSDATA,313,390),ACHSRTYP(7)=ACHSRTYP(7)+1
  1.  I ACHSTOS2'=57 S ACHSRCT=ACHSRCT+1,^ACHSDATA(ACHSRCT)="7F"_$E(ACHSDATA,391,468),ACHSRTYP(7)=ACHSRTYP(7)+1
  1.  I ACHSTOS2'=57 S ACHSRCT=ACHSRCT+1,^ACHSDATA(ACHSRCT)="7G"_$E(ACHSDATA,469,546),ACHSRTYP(7)=ACHSRTYP(7)+1
  1.  I ACHSTOS2'=57 S ACHSRCT=ACHSRCT+1,^ACHSDATA(ACHSRCT)="7H"_$E(ACHSDATA,547,624),ACHSRTYP(7)=ACHSRTYP(7)+1
  1.  ;For Inpatient Rec's only
  1.  I ACHSTOS2=43 S ACHSRCT=ACHSRCT+1,^ACHSDATA(ACHSRCT)="7I"_$E(ACHSDATA,625,702),ACHSRTYP(7)=ACHSRTYP(7)+1
  1.  I ACHSTOS2=43 S ACHSRCT=ACHSRCT+1,^ACHSDATA(ACHSRCT)="7J"_$E(ACHSDATA,703,780),ACHSRTYP(7)=ACHSRTYP(7)+1
  1.  I ACHSTOS2=43 S ACHSRCT=ACHSRCT+1,^ACHSDATA(ACHSRCT)="7K"_$E(ACHSDATA,781,858),ACHSRTYP(7)=ACHSRTYP(7)+1
  1.  I ACHSTOS2=43 S ACHSRCT=ACHSRCT+1,^ACHSDATA(ACHSRCT)="7L"_$E(ACHSDATA,859,936),ACHSRTYP(7)=ACHSRTYP(7)+1
  1.  I ACHSTOS2=43 S ACHSRCT=ACHSRCT+1,^ACHSDATA(ACHSRCT)="7M"_$E(ACHSDATA,937,1014),ACHSRTYP(7)=ACHSRTYP(7)+1
  1.  ;ACHS*3.1*14 IHS/OIT/FCJ CHANGE IN THE UNIQUE REG ID to 15 Char commented out nxt line and added nxt 2
  1.  ;S ACHSRCT=ACHSRCT+1,^ACHSDATA(ACHSRCT)="7X"_$$UID^AGTXID(DFN)_$J(ACHSDIEN,20)_$J("",42),ACHSRTYP(7)=ACHSRTYP(7)+1  ; ACHS*3.1*3
  1.  S ACHSAGID=$$GET1^DIQ(9999999.06,$P(^AUTTSITE(1,0),U),.32)_($E("0000000000",1,10-$L(DFN))_DFN)_" "
  1.  ;ACHS*3.1*23 REWROTE SECTION
  1.  ;S ACHSRCT=ACHSRCT+1,^ACHSDATA(ACHSRCT)="7X"_ACHSAGID_$J(ACHSDIEN,20)_$J("",42),ACHSRTYP(7)=ACHSRTYP(7)+1
  1.  S ACHSRCT=ACHSRCT+1 D
  1.  .I (DT<$$PARM^ACHS(0,18))!(ACHSTOS2=57) S ^ACHSDATA(ACHSRCT)="7X"_ACHSAGID_$J(ACHSDIEN,20)_$J("",42) Q
  1.  .I ACHSTOS2=43 S ^ACHSDATA(ACHSRCT)="7X"_ACHSAGID_$J(ACHSDIEN,20)_ACHSDX(7)_ACHSDX(8)_ACHSDX(9)_ACHSRCOI_$J("",10)
  1.  .I ACHSTOS2=64 S ^ACHSDATA(ACHSRCT)="7X"_ACHSAGID_$J(ACHSDIEN,20)_ACHSPX(1)_ACHSDX(6)_ACHSDX(7)_ACHSDX(8)_ACHSDX(9)_$J("",3)
  1.  S ACHSRTYP(7)=ACHSRTYP(7)+1
  1.  ;
  1.  I ACHSRTYP(7)#10=0 W $J(ACHSRTYP(7),8)
  1.  Q
  1. ICD ;REFERRAL CAUSE OF INJURY
  1.  S DA(1)=DUZ(2),DA=ACHSDIEN
  1.  S ACHSRCOI=$$VAL^XBDIQ1(9002080.01,.DA,82)
  1.  S:ACHSRCOI["E" ACHSRCOI=$P(ACHSRCOI,"E",2)
  1.  S:ACHSRCOI["." ACHSRCOI=$P(ACHSRCOI,".")_$P(ACHSRCOI,".",2)
  1.  S ACHSRCOI=$E(ACHSRCOI_$J("",4),1,4)
  1.  I +ACHSRCOI<1 S ACHSRCOI="    "
  1.  ;
  1.  K Z
  1.  F ACHSI=1:1:9 I ACHSDX(ACHSI)["E" S Z(ACHSI)=ACHSDX(ACHSI) F ACHSJ=ACHSI:1 Q:ACHSJ=9  S ACHSDX(ACHSJ)=ACHSDX(ACHSJ+1),ACHSDX(ACHSJ+1)="     "
  1.  S W=0,ACHSINJP="  ",W=$O(Z(W))
  1.  I W>0 S ACHSRCOI=$E(Z(W),2,5),ACHSINJP="12"
  1.  S Z=""
  1.  F ACHSI=1:1:5 I +$E(ACHSDX(ACHSI),1,3)>799 S Z="EC"
  1.  I Z="EC"&(ACHSRCOI="    ") S ACHSRCOI="9889",ACHSINJP="12"
  1.  Q
  1. ICD10 ;ACHS*3.1*23 REFERRAL CAUSE OF INJ
  1.  S ACHSINJP="  ",DA(1)=DUZ(2),DA=ACHSDIEN
  1.  S ACHSRCOI=$$VAL^XBDIQ1(9002080.01,.DA,82)
  1.  S ACHSRCOI=$E(ACHSRCOI_"        ",1,8)
  1.  Q