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