ACHSTX8 ; IHS/ITSC/PMF - EXPORT DATA (9/9) - EOJ ;JUL 10, 2008
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5,6,11,13,14,19,23,25**;JUN 11,2001;Build 43
;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Capture number of individual records.
;IHS/SET/JVK ACHS*3.1*6 4/23/2003 - If site acts as area don't que file
;ACHS*3.1*13 6.16.2007 IHS/OIT/FCJ Added new rec type of "U" and trans to Export status file
;;ACHS*3.1*14 2.28.2008 IHS/OIT/FCJ Added test for OCC and Re-export option
U IO(0)
W !!?5,".....EXPORT CHS DATA",!!
I ACHSROUT<1 G NORECDS
;ACHS*3.1*13 IHS/OIT/FCJ ADDED UFMS REC 8 TO NXT LINE
F ACHSY=2:1:7,8 S ACHSTYP(ACHSY)=$$REC^ACHSACO1(ACHSY)
D R1
I $$DIR^XBDIR("E","Enter <RETURN> to Continue")
I '$D(ACHSCRTN) S ACHSCRTN=""
I '$D(ACHSMDAT) S ACHSMDAT=DT
;ITSC/SET/JVK ACHS*3.1*11 LOOK FOR VERSION AND PATCH
S (ACHSVDA,ACHSPA)=""
S ACHSVDA=$O(^DIC(9.4,"B","CONTRACT HEALTH MGMT SYSTEM",ACHSVDA))
S ACHSVER=$P(^DIC(9.4,ACHSVDA,"VERSION"),U)
S ACHSPA=$O(^DIC(9.4,ACHSVDA,22,"B",ACHSVER,ACHSPA))
;S ACHSPA=$P(^DIC(9.4,119,22,3,"PAH",0),U,4)
;S ACHSPA=$P(^DIC(9.4,ACHSVDA,22,ACHSPA,"PAH",0),U,4) ;ACHS*3.1*23
S ACHSPA=$P(^DIC(9.4,ACHSVDA,22,ACHSPA,"PAH",0),U,4) S:ACHSPA>10 ACHSPA=11 ;ACHS
;ITSC/SET/JVK ACHS*3.1*11 ADD VERSION OF CHS TO ZERO NODE
;S ^ACHSDATA(0)=$P($G(^AUTTLOC(DUZ(2),0)),U,10)_U_$$LOC^ACHS_U_DT_U_ACHSFDT_U_ACHSLDAT_"^^"_ACHSRTYP_U_ACHSCRTN_U_ACHSMDAT_U_$P($G(^ACHS(9,DUZ(2),"FY",ACHSCFY,0)),U,2)_U_$P($G(^ACHS(9,DUZ(2),"FY",ACHSCFY,0)),U,3)
;S ^ACHSDATA(0)=$P($G(^AUTTLOC(DUZ(2),0)),U,10)_U_$$LOC^ACHS_U_DT_U_ACHSFDT_U_ACHSLDAT_"^^"_ACHSRTYP_U_ACHSCRTN_U_ACHSMDAT_U_$P($G(^ACHS(9,DUZ(2),"FY",ACHSCFY,0)),U,2)_U_$P($G(^ACHS(9,DUZ(2),"FY",ACHSCFY,0)),U,3)_U_ACHSVER_"*"_ACHSPA
;ACHS*3.1*23 CHG NXT LN TO TEST FOR ICD9 OR ICD10 FORMAT
I DT<$$PARM^ACHS(0,18) D SETR1
E D SETR2
; Set up Qed report.
I ACHSIO=IO G NOQUE
S ZTRTN="REPORT^ACHSTX8",ZTDTH=$H,ZTIO=ACHSION,ZTDESC="REPORT OF EXPORT RECORDS, for "_$P($G(^AUTTLOC(DUZ(2),0)),U,2)_"."
F %="ACHSFDT","ACHSRTYP","ACHSRTYP(","ACHSLDAT","ACHSTYP(" S ZTSAVE(%)=""
D ^%ZTLOAD
NOQUE ; Report not q'd.
I ACHSREEX D REPORT G WRITETP
;I $D(ACHSPPO) D REPORT
S DIE="^ACHSTXST("
I '$D(^ACHSTXST("B",DUZ(2))) S $P(^ACHSTXST(0),U,3)=DUZ(2),^ACHSTXST(DUZ(2),0)=DUZ(2),$P(^ACHSTXST(0),U,4)=$P(^ACHSTXST(0),U,4)+1,^ACHSTXST("B",DUZ(2),DUZ(2))=""
S DA=DUZ(2),DR="1///"_DT,DR(2,9002070.01)=".01///"_DT
D ^DIE
S DA(1)=1
F ACHS=0:0 S ACHS=$O(^ACHSTXST(DUZ(2),1,ACHS)) Q:ACHS<1 S DA(1)=ACHS
S ^ACHSTXST(DUZ(2),1,DA(1),0)=DT_U_ACHSFDT_U_ACHSLDAT_"^^"_ACHSROUT_U_ACHSCRTN_U_ACHSMDAT_"^^^N"
D NUMRECS(DA(1)) ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
WRITETP ; Save global for export.
S XBGL="ACHSDATA",XBNAR="CONTRACT HEALTH export data",XBMED="F"
;IHS/SET/JVK ACHS*3.1*6 FOR THOSE SITES SENDING DIRECT TO FI
I $$GET1^DIQ(9002079,DUZ(2),1412,"I")="N" S XBQTO=""
;
S XBFN="ACHS"_$P($G(^AUTTLOC(DUZ(2),0)),U,10) ;ACHS*3.1*19
D NOW^%DTC S XBFN=XBFN_"."_(%I(3)+1700)_$E(%,4,7)_"_"_$P(%,".",2) ;ACHS*3.1*19
I $P(^AUTTSITE(1,0),U,14)'="",$D(^%ZIB(9888888.93,"B",$P(^AUTTSITE(1,0),U,14))) S XBS1=$P(^AUTTSITE(1,0),U,14) ;ACHS*3.1*25
D ^XBGSAVE ;Saves and sends global
I XBFLG G JOBABEND
I 'ACHSREEX S $P(^ACHSTXST(DUZ(2),1,DA(1),0),U,10)="Y"
I $D(ACHSPPO) D REPORT
G ENTRETRN
;
JOBABEND ;EP.
W !!?10,"ABNORMAL END OF CHS EXPORT"
I $D(XBFLG),XBFLG W !!,XBFLG(1),! K XBFLG
G ENTRETRN
;
TXFEF ;EP.
W !!,"EXPORT PROGRAM ALREADY RUN THIS DATE FOR THIS FACILITY",*7
;TPF;FOR CLEARING: EDIT 'CHS TX STATUS' FILE ENTER FACILITY NAME AND DELETE
ENTRETRN ;
W !
I $$DIR^XBDIR("E","Press RETURN...")
KILL ;EP - Kill vars, close device, quit.
I '$$LOCK^ACHS("^ACHSF(DUZ(2),""D"")","-")
K %DT,X1,XBDT,XBF,XBGL,XBTIT,ACHSCRTN,DA,DIC,DIE,DR,DUOUT,DX,DY
;
;for test !!!!! only delete vars if reexporting
I ACHSREEX D EN^XBVK("ACHS"),^%ZISC,^ACHSVAR Q
K ACHSTXTY,^TMP("ACHSTX",$J)
D ^%ZISC
Q
;
NORECDS ;EP
W !!,*7,?10,"NO RECORDS GENERATED FOR EXPORT",!!
G ENTRETRN
;
REPORT ;EP - From TaskMan.
U IO
D LINES^ACHSFU,NOW^ACHS
S ACHSTIME=$$C^XBFUNC(ACHSTIME,80),X=$$C^XBFUNC($$LOC^ACHS,80)
X:$D(ACHSPPO) ACHSPPO
W @IOF,!,ACHS("*"),!,"*",?25,"CONTRACT HEALTH MANAGEMENT SYSTEM",?78,"*",!,"*",?30,"EXPORTED RECORDS BY TYPE",?78,"*",!,"*",$E(X,2,80),?78,"*",!,"*",$E(ACHSTIME,2,80),?78,"*",!,ACHS("*"),!!!
D R1
W @IOF
X:$D(ACHSPPC) ACHSPPC
D ERPT^ACHS
Q
;
R1 ; Print basic info for the report.
W ?20,"BEGINNING ADD/UPD DATE",?45,"=",?50,$$FMTE^XLFDT(ACHSFDT),!!?20,"ENDING ADD/UPD DATE",?45,"=",?50,$$FMTE^XLFDT(ACHSLDAT),!!?15,$$REPEAT^XLFSTR("-",47),!?15,"T Y P E O F R E C O R D",?55,"NUMBER",!?15,$$REPEAT^XLFSTR("-",47),!!
S ACHSRTYP=0
;ACHS*3.1*13 IHS/OIT/FCJ CHG 7 TO 8 TO NXT LINE
F ACHS=2:1:8 W ?10,ACHS,".",?15,ACHSTYP(ACHS),?55,$J(ACHSRTYP(ACHS),6),! S ACHSRTYP=ACHSRTYP+ACHSRTYP(ACHS)
W !?20,"TOTAL ALL TYPES",?55,$J(ACHSRTYP,6),!!
Q
;
CANOBJ ;EP - Set CAN, ObjClass, & SCC into ACHSCAN, ACHSOBJC, ACHSSCC.
S (ACHSCAN,ACHSSCC,ACHSOBJC)=""
S:$P(ACHSDOCR,U,6)'="" ACHSCAN=$P($G(^ACHS(2,$P(ACHSDOCR,U,6),0)),U)
S:$P(ACHSDOCR,U,7)'="" ACHSSCC=$P($G(^ACHS(3,DUZ(2),1,$P(ACHSDOCR,U,7),0)),U)
;ACHS*3.1*14 2.28.2008 IHS/OIT/FCJ ADDED NXT LINE TO TEST FOR OCC IF NOT IN FILE USES SCC DEFAULT
I $P(ACHSDOCR,U,10)'="",$G(^ACHSOCC($P(ACHSDOCR,U,10),0))="" S ACHSOBJC=$P(ACHSDOCR,U,10) Q
S:$P(ACHSDOCR,U,10)'="" ACHSOBJC=$P($G(^ACHSOCC($P(ACHSDOCR,U,10),0)),U)
Q
;
IPA ;EP - Set IHS pay amt into ACHSIPA.
S X=$P(ACHSTRAN,U,4),X=$P(X,".")_$E($P(X,".",2)_"00",1,2),ACHSIPA=$E(X+1000000000000,2,13)
Q
;
TOS ;EP - Set document type into ACHSTOS2.
S X=$P(ACHSDOCR,U,4),ACHSTOS2=$S(X=1:43,X=2:57,X=3:64,1:" ")
Q
;
TRIB ;EP - Set patient's tribe into ACHSTRIB.
S ACHSTRIB="999"
I $D(^AUPNPAT(DFN,11)),$P($G(^(11)),U,8),$D(^AUTTTRI($P(^(11),U,8),0)),$L($P(^(0),U,2))=3 S ACHSTRIB=$P(^(0),U,2)
Q
;
;Begin New Code;IHS/SET/GTH ACHS*3.1*5 12/06/2002
NUMRECS(DA) ;
NEW DIE,DR
S DA(1)=DUZ(2),DIE="^ACHSTXST("_DA(1)_",1,",DR=""
F %=11:1:17 S DR=DR_";"_%_"///"_$G(ACHSRTYP(%-10),"0")
S DR=$E(DR,2,99999)
S DR=DR_";18///"_ACHSRTYP(8)_";19///"_ACHSTXTY ;ACHS*3.1*13 IHS/OIT/FCJ Rec type "U" and type of export
D ^DIE
;End New Code;IHS/SET/GTH ACHS*3.1*5 12/06/2002
TST ;ADD TRANSACTIONS TO CHS TX STATUS FILE
Q:'$D(^TMP("ACHSTX",$J))
S DA(2)=DUZ(2),DA(1)=DA
S (DIC,DIE)="^ACHSTXST("_DA(2)_",1,"_DA(1)_",2,"
S DIC("P")=$P(^DD(9002070.01,201,0),U,2),DIC(0)="L",DLAYGO=9002070,DIADD=1
S P=0 F S P=$O(^TMP("ACHSTX",$J,P)) Q:P'?1N.N D
.S T=0 F S T=$O(^TMP("ACHSTX",$J,P,T)) Q:T'?1N.N D
..S X=P D ^DIC S DA=+Y
..S DR=".02////"_T
..D ^DIE
;Update export date in Facility file
;ACHS*3.1*14 11/1/2008 IHS/OIT/FCJ TEST FOR REEXPORT
I 'ACHSREEX S $P(^ACHSF(DUZ(2),0),U,14)=DT
Q
SETR1 ;ICD-9 FORMAT;ACHS*3.1*23
S ^ACHSDATA(0)=$P($G(^AUTTLOC(DUZ(2),0)),U,10)_U_$$LOC^ACHS_U_DT_U_ACHSFDT_U_ACHSLDAT_"^^"_ACHSRTYP_U_ACHSCRTN_U_ACHSMDAT_U_$P($G(^ACHS(9,DUZ(2),"FY",ACHSCFY,0)),U,2)_U_$P($G(^ACHS(9,DUZ(2),"FY",ACHSCFY,0)),U,3)_U_ACHSVER_"*"_ACHSPA
Q
SETR2 ;ICD-10 FORMAT;ACHS*3.1*23
S ^ACHSDATA(0)=$P($G(^AUTTLOC(DUZ(2),0)),U,10)_U_$$LOC^ACHS_U_DT_U_ACHSFDT_U_ACHSLDAT_"^^"_ACHSRTYP_U_ACHSCRTN_U_ACHSMDAT_U_$P($G(^ACHS(9,DUZ(2),"FY",ACHSCFY,0)),U,2)_U_$P($G(^ACHS(9,DUZ(2),"FY",ACHSCFY,0)),U,3)_U_"CRV003"
Q
ACHSTX8 ; IHS/ITSC/PMF - EXPORT DATA (9/9) - EOJ ;JUL 10, 2008
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5,6,11,13,14,19,23,25**;JUN 11,2001;Build 43
+2 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Capture number of individual records.
+3 ;IHS/SET/JVK ACHS*3.1*6 4/23/2003 - If site acts as area don't que file
+4 ;ACHS*3.1*13 6.16.2007 IHS/OIT/FCJ Added new rec type of "U" and trans to Export status file
+5 ;;ACHS*3.1*14 2.28.2008 IHS/OIT/FCJ Added test for OCC and Re-export option
+6 USE IO(0)
+7 WRITE !!?5,".....EXPORT CHS DATA",!!
+8 IF ACHSROUT<1
GOTO NORECDS
+9 ;ACHS*3.1*13 IHS/OIT/FCJ ADDED UFMS REC 8 TO NXT LINE
+10 FOR ACHSY=2:1:7,8
SET ACHSTYP(ACHSY)=$$REC^ACHSACO1(ACHSY)
+11 DO R1
+12 IF $$DIR^XBDIR("E","Enter <RETURN> to Continue")
+13 IF '$DATA(ACHSCRTN)
SET ACHSCRTN=""
+14 IF '$DATA(ACHSMDAT)
SET ACHSMDAT=DT
+15 ;ITSC/SET/JVK ACHS*3.1*11 LOOK FOR VERSION AND PATCH
+16 SET (ACHSVDA,ACHSPA)=""
+17 SET ACHSVDA=$ORDER(^DIC(9.4,"B","CONTRACT HEALTH MGMT SYSTEM",ACHSVDA))
+18 SET ACHSVER=$PIECE(^DIC(9.4,ACHSVDA,"VERSION"),U)
+19 SET ACHSPA=$ORDER(^DIC(9.4,ACHSVDA,22,"B",ACHSVER,ACHSPA))
+20 ;S ACHSPA=$P(^DIC(9.4,119,22,3,"PAH",0),U,4)
+21 ;S ACHSPA=$P(^DIC(9.4,ACHSVDA,22,ACHSPA,"PAH",0),U,4) ;ACHS*3.1*23
+22 ;ACHS
SET ACHSPA=$PIECE(^DIC(9.4,ACHSVDA,22,ACHSPA,"PAH",0),U,4)
IF ACHSPA>10
SET ACHSPA=11
+23 ;ITSC/SET/JVK ACHS*3.1*11 ADD VERSION OF CHS TO ZERO NODE
+24 ;S ^ACHSDATA(0)=$P($G(^AUTTLOC(DUZ(2),0)),U,10)_U_$$LOC^ACHS_U_DT_U_ACHSFDT_U_ACHSLDAT_"^^"_ACHSRTYP_U_ACHSCRTN_U_ACHSMDAT_U_$P($G(^ACHS(9,DUZ(2),"FY",ACHSCFY,0)),U,2)_U_$P($G(^ACHS(9,DUZ(2),"FY",ACHSCFY,0)),U,3)
+25 ;S ^ACHSDATA(0)=$P($G(^AUTTLOC(DUZ(2),0)),U,10)_U_$$LOC^ACHS_U_DT_U_ACHSFDT_U_ACHSLDAT_"^^"_ACHSRTYP_U_ACHSCRTN_U_ACHSMDAT_U_$P($G(^ACHS(9,DUZ(2),"FY",ACHSCFY,0)),U,2)_U_$P($G(^ACHS(9,DUZ(2),"FY",ACHSCFY,0)),U,3)_U_ACHSVER_"*"_ACHSPA
+26 ;ACHS*3.1*23 CHG NXT LN TO TEST FOR ICD9 OR ICD10 FORMAT
+27 IF DT<$$PARM^ACHS(0,18)
DO SETR1
+28 IF '$TEST
DO SETR2
+29 ; Set up Qed report.
+30 IF ACHSIO=IO
GOTO NOQUE
+31 SET ZTRTN="REPORT^ACHSTX8"
SET ZTDTH=$HOROLOG
SET ZTIO=ACHSION
SET ZTDESC="REPORT OF EXPORT RECORDS, for "_$PIECE($GET(^AUTTLOC(DUZ(2),0)),U,2)_"."
+32 FOR %="ACHSFDT","ACHSRTYP","ACHSRTYP(","ACHSLDAT","ACHSTYP("
SET ZTSAVE(%)=""
+33 DO ^%ZTLOAD
NOQUE ; Report not q'd.
+1 IF ACHSREEX
DO REPORT
GOTO WRITETP
+2 ;I $D(ACHSPPO) D REPORT
+3 SET DIE="^ACHSTXST("
+4 IF '$DATA(^ACHSTXST("B",DUZ(2)))
SET $PIECE(^ACHSTXST(0),U,3)=DUZ(2)
SET ^ACHSTXST(DUZ(2),0)=DUZ(2)
SET $PIECE(^ACHSTXST(0),U,4)=$PIECE(^ACHSTXST(0),U,4)+1
SET ^ACHSTXST("B",DUZ(2),DUZ(2))=""
+5 SET DA=DUZ(2)
SET DR="1///"_DT
SET DR(2,9002070.01)=".01///"_DT
+6 DO ^DIE
+7 SET DA(1)=1
+8 FOR ACHS=0:0
SET ACHS=$ORDER(^ACHSTXST(DUZ(2),1,ACHS))
IF ACHS<1
QUIT
SET DA(1)=ACHS
+9 SET ^ACHSTXST(DUZ(2),1,DA(1),0)=DT_U_ACHSFDT_U_ACHSLDAT_"^^"_ACHSROUT_U_ACHSCRTN_U_ACHSMDAT_"^^^N"
+10 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
DO NUMRECS(DA(1))
WRITETP ; Save global for export.
+1 SET XBGL="ACHSDATA"
SET XBNAR="CONTRACT HEALTH export data"
SET XBMED="F"
+2 ;IHS/SET/JVK ACHS*3.1*6 FOR THOSE SITES SENDING DIRECT TO FI
+3 IF $$GET1^DIQ(9002079,DUZ(2),1412,"I")="N"
SET XBQTO=""
+4 ;
+5 ;ACHS*3.1*19
SET XBFN="ACHS"_$PIECE($GET(^AUTTLOC(DUZ(2),0)),U,10)
+6 ;ACHS*3.1*19
DO NOW^%DTC
SET XBFN=XBFN_"."_(%I(3)+1700)_$EXTRACT(%,4,7)_"_"_$PIECE(%,".",2)
+7 ;ACHS*3.1*25
IF $PIECE(^AUTTSITE(1,0),U,14)'=""
IF $DATA(^%ZIB(9888888.93,"B",$PIECE(^AUTTSITE(1,0),U,14)))
SET XBS1=$PIECE(^AUTTSITE(1,0),U,14)
+8 ;Saves and sends global
DO ^XBGSAVE
+9 IF XBFLG
GOTO JOBABEND
+10 IF 'ACHSREEX
SET $PIECE(^ACHSTXST(DUZ(2),1,DA(1),0),U,10)="Y"
+11 IF $DATA(ACHSPPO)
DO REPORT
+12 GOTO ENTRETRN
+13 ;
JOBABEND ;EP.
+1 WRITE !!?10,"ABNORMAL END OF CHS EXPORT"
+2 IF $DATA(XBFLG)
IF XBFLG
WRITE !!,XBFLG(1),!
KILL XBFLG
+3 GOTO ENTRETRN
+4 ;
TXFEF ;EP.
+1 WRITE !!,"EXPORT PROGRAM ALREADY RUN THIS DATE FOR THIS FACILITY",*7
+2 ;TPF;FOR CLEARING: EDIT 'CHS TX STATUS' FILE ENTER FACILITY NAME AND DELETE
ENTRETRN ;
+1 WRITE !
+2 IF $$DIR^XBDIR("E","Press RETURN...")
KILL ;EP - Kill vars, close device, quit.
+1 IF '$$LOCK^ACHS("^ACHSF(DUZ(2),""D"")","-")
+2 KILL %DT,X1,XBDT,XBF,XBGL,XBTIT,ACHSCRTN,DA,DIC,DIE,DR,DUOUT,DX,DY
+3 ;
+4 ;for test !!!!! only delete vars if reexporting
+5 IF ACHSREEX
DO EN^XBVK("ACHS")
DO ^%ZISC
DO ^ACHSVAR
QUIT
+6 KILL ACHSTXTY,^TMP("ACHSTX",$JOB)
+7 DO ^%ZISC
+8 QUIT
+9 ;
NORECDS ;EP
+1 WRITE !!,*7,?10,"NO RECORDS GENERATED FOR EXPORT",!!
+2 GOTO ENTRETRN
+3 ;
REPORT ;EP - From TaskMan.
+1 USE IO
+2 DO LINES^ACHSFU
DO NOW^ACHS
+3 SET ACHSTIME=$$C^XBFUNC(ACHSTIME,80)
SET X=$$C^XBFUNC($$LOC^ACHS,80)
+4 IF $DATA(ACHSPPO)
XECUTE ACHSPPO
+5 WRITE @IOF,!,ACHS("*"),!,"*",?25,"CONTRACT HEALTH MANAGEMENT SYSTEM",?78,"*",!,"*",?30,"EXPORTED RECORDS BY TYPE",?78,"*",!,"*",$EXTRACT(X,2,80),?78,"*",!,"*",$EXTRACT(ACHSTIME,2,80),?78,"*",!,ACHS("*"),!!!
+6 DO R1
+7 WRITE @IOF
+8 IF $DATA(ACHSPPC)
XECUTE ACHSPPC
+9 DO ERPT^ACHS
+10 QUIT
+11 ;
R1 ; Print basic info for the report.
+1 WRITE ?20,"BEGINNING ADD/UPD DATE",?45,"=",?50,$$FMTE^XLFDT(ACHSFDT),!!?20,"ENDING ADD/UPD DATE",?45,"=",?50,$$FMTE^XLFDT(ACHSLDAT),!!?15,$$REPEAT^XLFSTR("-",47),!?15,"T Y P E O F R E C O R D",?55,"NUMBER",!?15,$$REPEAT^XLFSTR("-",47),!!
+2 SET ACHSRTYP=0
+3 ;ACHS*3.1*13 IHS/OIT/FCJ CHG 7 TO 8 TO NXT LINE
+4 FOR ACHS=2:1:8
WRITE ?10,ACHS,".",?15,ACHSTYP(ACHS),?55,$JUSTIFY(ACHSRTYP(ACHS),6),!
SET ACHSRTYP=ACHSRTYP+ACHSRTYP(ACHS)
+5 WRITE !?20,"TOTAL ALL TYPES",?55,$JUSTIFY(ACHSRTYP,6),!!
+6 QUIT
+7 ;
CANOBJ ;EP - Set CAN, ObjClass, & SCC into ACHSCAN, ACHSOBJC, ACHSSCC.
+1 SET (ACHSCAN,ACHSSCC,ACHSOBJC)=""
+2 IF $PIECE(ACHSDOCR,U,6)'=""
SET ACHSCAN=$PIECE($GET(^ACHS(2,$PIECE(ACHSDOCR,U,6),0)),U)
+3 IF $PIECE(ACHSDOCR,U,7)'=""
SET ACHSSCC=$PIECE($GET(^ACHS(3,DUZ(2),1,$PIECE(ACHSDOCR,U,7),0)),U)
+4 ;ACHS*3.1*14 2.28.2008 IHS/OIT/FCJ ADDED NXT LINE TO TEST FOR OCC IF NOT IN FILE USES SCC DEFAULT
+5 IF $PIECE(ACHSDOCR,U,10)'=""
IF $GET(^ACHSOCC($PIECE(ACHSDOCR,U,10),0))=""
SET ACHSOBJC=$PIECE(ACHSDOCR,U,10)
QUIT
+6 IF $PIECE(ACHSDOCR,U,10)'=""
SET ACHSOBJC=$PIECE($GET(^ACHSOCC($PIECE(ACHSDOCR,U,10),0)),U)
+7 QUIT
+8 ;
IPA ;EP - Set IHS pay amt into ACHSIPA.
+1 SET X=$PIECE(ACHSTRAN,U,4)
SET X=$PIECE(X,".")_$EXTRACT($PIECE(X,".",2)_"00",1,2)
SET ACHSIPA=$EXTRACT(X+1000000000000,2,13)
+2 QUIT
+3 ;
TOS ;EP - Set document type into ACHSTOS2.
+1 SET X=$PIECE(ACHSDOCR,U,4)
SET ACHSTOS2=$SELECT(X=1:43,X=2:57,X=3:64,1:" ")
+2 QUIT
+3 ;
TRIB ;EP - Set patient's tribe into ACHSTRIB.
+1 SET ACHSTRIB="999"
+2 IF $DATA(^AUPNPAT(DFN,11))
IF $PIECE($GET(^(11)),U,8)
IF $DATA(^AUTTTRI($PIECE(^(11),U,8),0))
IF $LENGTH($PIECE(^(0),U,2))=3
SET ACHSTRIB=$PIECE(^(0),U,2)
+3 QUIT
+4 ;
+5 ;Begin New Code;IHS/SET/GTH ACHS*3.1*5 12/06/2002
NUMRECS(DA) ;
+1 NEW DIE,DR
+2 SET DA(1)=DUZ(2)
SET DIE="^ACHSTXST("_DA(1)_",1,"
SET DR=""
+3 FOR %=11:1:17
SET DR=DR_";"_%_"///"_$GET(ACHSRTYP(%-10),"0")
+4 SET DR=$EXTRACT(DR,2,99999)
+5 ;ACHS*3.1*13 IHS/OIT/FCJ Rec type "U" and type of export
SET DR=DR_";18///"_ACHSRTYP(8)_";19///"_ACHSTXTY
+6 DO ^DIE
+7 ;End New Code;IHS/SET/GTH ACHS*3.1*5 12/06/2002
TST ;ADD TRANSACTIONS TO CHS TX STATUS FILE
+1 IF '$DATA(^TMP("ACHSTX",$JOB))
QUIT
+2 SET DA(2)=DUZ(2)
SET DA(1)=DA
+3 SET (DIC,DIE)="^ACHSTXST("_DA(2)_",1,"_DA(1)_",2,"
+4 SET DIC("P")=$PIECE(^DD(9002070.01,201,0),U,2)
SET DIC(0)="L"
SET DLAYGO=9002070
SET DIADD=1
+5 SET P=0
FOR
SET P=$ORDER(^TMP("ACHSTX",$JOB,P))
IF P'?1N.N
QUIT
Begin DoDot:1
+6 SET T=0
FOR
SET T=$ORDER(^TMP("ACHSTX",$JOB,P,T))
IF T'?1N.N
QUIT
Begin DoDot:2
+7 SET X=P
DO ^DIC
SET DA=+Y
+8 SET DR=".02////"_T
+9 DO ^DIE
End DoDot:2
End DoDot:1
+10 ;Update export date in Facility file
+11 ;ACHS*3.1*14 11/1/2008 IHS/OIT/FCJ TEST FOR REEXPORT
+12 IF 'ACHSREEX
SET $PIECE(^ACHSF(DUZ(2),0),U,14)=DT
+13 QUIT
SETR1 ;ICD-9 FORMAT;ACHS*3.1*23
+1 SET ^ACHSDATA(0)=$PIECE($GET(^AUTTLOC(DUZ(2),0)),U,10)_U_$$LOC^ACHS_U_DT_U_ACHSFDT_U_ACHSLDAT_"^^"_ACHSRTYP_U_ACHSCRTN_U_ACHSMDAT_U_$P($GET(^ACHS(9,DUZ(2),"FY",ACHSCFY,0)),U,2)_U_$PIECE($GET(^ACHS(9,DUZ(2),"FY",ACHSCFY,0)),U,3)_U_ACHSVER_"*"_AC
HSPA
+2 QUIT
SETR2 ;ICD-10 FORMAT;ACHS*3.1*23
+1 SET ^ACHSDATA(0)=$PIECE($GET(^AUTTLOC(DUZ(2),0)),U,10)_U_$$LOC^ACHS_U_DT_U_ACHSFDT_U_ACHSLDAT_"^^"_ACHSRTYP_U_ACHSCRTN_U_ACHSMDAT_U_$P($GET(^ACHS(9,DUZ(2),"FY",ACHSCFY,0)),U,2)_U_$PIECE($GET(^ACHS(9,DUZ(2),"FY",ACHSCFY,0)),U,3)_U_"CRV003"
+2
*** ERROR ***
