ACHSPCC3 ; IHS/ITSC/PMF - CHS AREA SPLITOUT (3/5)(WRITE TO FLATFILES) ;
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**11,13,19,21,23**;JUN 11,2001;Build 43
;ACHS*3.1*3 add UID to NPRS data
;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Reinstate display filename.
;ITSC/SET/JVK ACHS*3.1*11 ADDED ADDITONAL RECORRDS FOR STAT PURPOSES
;ACHS*3.1*13 IHS/OIT/FCJ ADDED UFMS PROCESSING
S (ACHSFLG,ACHSGCTR)=0
G PCC4
;
START ;
;I ACHSGLBL="^ACHSBCBS",($$AOP^ACHS(2,8)=""!($$AOP^ACHS(2,8)="N")) G PCC4
I ACHSGCTR=1,ACHSCT2=0 G PCC4
S X=$O(@(ACHSGLBL_"(0)"))
I +X<1 G PCC4
I +X="**" G PCC4
MSM ;
U IO(0)
W !!,"Processing the ",ACHSGLBL," (",ACHSDESC,") transaction file."
S ACHSMED="F"
D UNIX:"Ff"[ACHSMED
I $D(ACHSJFLG) D JOBABEND^ACHSPCC4 Q
PCC4 ;
I ACHSFLG D JOBABEND^ACHSPCC4 Q
S ACHSGCTR=ACHSGCTR+1,ACHSGLBL=$P($T(@"GLOBS"+ACHSGCTR),";",3),ACHSDESC=$P($T(@"GLOBS"+ACHSGCTR),";",4),ACHSSUF=$P($T(@"GLOBS"+ACHSGCTR),";",5)
I ACHSGLBL="^ACHSUFMS" D UFMS G PCC4 ;ACHS*3.1*13 IHS/OIT/FCJ
I ACHSGLBL']"" D END^ACHSPCC4 Q
;I ACHSGLBL
I ACHSGLBL="^ACHSBCBS",$$AOP^ACHS(2,8)="Y" G START
;ITSC/SET/JVK ACHS*3.1*11;ACHS*3.1*23
;I ACHSGLBL="^ACHSPIG" S ACHSSUF=ACHSSUF_$E($P(^AUTTLOC(DUZ(2),0),U,10),1,2)_"0000"
I (ACHSGLBL="^ACHSPIG")!(ACHSGLBL="^ACHSPG2") S ACHSSUF=ACHSSUF_$E($P(^AUTTLOC(DUZ(2),0),U,10),1,2)_"0000"
G PCC4:'$O(@(ACHSGLBL_"(0)"))
G START
;
UNIX ;
S ACHSFAC=$P(^AUTTLOC(DUZ(2),0),U,10)
;S ACHSCCTR="PCC"
S ACHSHDNM=ACHSSUF
I ACHSHDNM="DHR" S ACHSHDNM="DHRP"
I ACHSGLBL="^ACHSCORE" S ACHSHDNM="DHRC"
S ACHSPGNM="ACHS",ACHSZIN=1
D FILESEL^ACHSEXUT
I $D(ACHSJFLG) G END
S ACHSZFN=ACHSEXFN,ACHSZIN=0
;ACHS*3.1*21 CHANGED FILE NAME TO ALLOW MORE THEN 1 EXPORT A DAY...
S X=$E(DT,4,7)_$E(DT,2,3)
D NOW^%DTC S X=(%I(3)+1700)_$E(%,4,7)_"_"_$P(%,".",2)
S $P(ACHSZFN,".",2)=X
D OPENHFS^ACHSTCK1
I ACHSZZA D ERROR^ACHSTCK1 D JOBABEND^ACHSPCC4 Q
I ACHSGCTR=1 S ACHSDHRN=ACHSZFN
S IO=ACHSZDEV
U IO(0)
;W !,"Please Standby - Copying Data to File: " ;,!?10,ACHSEXFS;IHS/SET/GTH ACHS*3.1*5 12/06/2002
W !,"Please Standby - Copying Data to File: ",!?10,ACHSZFN ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
D AZGSAV1M
CLOSE ;EP
D ^%ZISC
U IO(0)
W !!?10,ACHSTXRC," Total Records Copied to Output Media",!
D RTRN^ACHS,TXLOGADD^ACHSTXUT
I ACHSY>0 G NORMEND
U IO(0)
W !,*7,?5,"UNABLE TO POST ENTRY TO IHS DATA TRANSMISSION LOG - NOTIFY SUPERVISOR" ;ACHS*3.1*21 ADDED LINE FEED
S ACHSFLG=1
G END
;
NORMEND ;
I $D(^AFSTXLOG(0)) D
. S $P(^AFSTXLOG(DUZ(2),1,ACHSY,0),U,3)=$$HTFM^XLFDT($H)
. S $P(^AFSTXLOG(DUZ(2),1,ACHSY,0),U,4)="Y"
. S:$D(ACHSTXRC) $P(^AFSTXLOG(DUZ(2),1,ACHSY,0),U,2)=ACHSTXRC
. N DA,DIK
. S DIK="^AFSTXLOG("_DUZ(2)_",1,",DA(1)=DUZ(2),DA=ACHSY
. D IX^DIK
.Q
;
END ; Kill vars, post 1166 open doc, quit.
K ACHS,ACHS7A,ACHSFAC,ACHSMSG,ACHSRCTR,ACHSRR,ACHSRRCT,X1,X2
Q:$D(ACHSJFLG)
Q:'$L($T(FRD^AFSLODF0))
Q:$$AOP^ACHS(2,12)'="Y"
Q:$G(ACHSZFN)'["chsdh"
; Post 1166 open document file.
W !,"Begin Posting DHR file to 1166 Open Document File..."
S AFSXPFN=ACHSDHRN
D FRD^AFSLODF0
K AFSXPFN
W !,"End Posting DHR file to 1166 Open Document File..."
Q
;
AZGSAV1M ;
U IO(0)
D WAIT^DICD
S DX=$X,DY=$Y,R="0",(ACHSRCTR,ACHSRR,ACHSRRR,ACHSRRCT,ACHSRRRC,ACHSTXRC)=0
S:ACHSGCTR=1 DY=DY+1
W !
AZGSHJCL ;
;ACHS*3.1*23 ADDED SECOND STAT FILE FOR ICD-10
;D PCCHJCL^ACHSPCC4:ACHSGCTR=1,DPSHJCL^ACHSPCC4:ACHSGCTR=5,FIHJCL^ACHSPCC4:ACHSGCTR=2
D PCCHJCL^ACHSPCC4:ACHSGCTR=1,DPSHJCL^ACHSPCC4:(ACHSGCTR=5)!(ACHSGCTR=8),FIHJCL^ACHSPCC4:ACHSGCTR=2
AZGS1 ;
S ACHSREF=ACHSGLBL_"("""_R_""")",R=$O(@ACHSREF) G AZGSTJCL:+R<1 S ACHSRCTR=+R I $D(^(R))<2 S X=^(R) D PADWRITE G AZGS1
S ACHSRR=0
AZGS2 ;
S ACHSREF=ACHSGLBL_"("""_R_""","_ACHSRR_")",ACHSRR=$O(@ACHSREF) G AZGS1:+ACHSRR<1 I $D(^(ACHSRR))<2 S X=^(ACHSRR),ACHSRRCT=ACHSRR D PADWRITE G AZGS2
S ACHSRRR=0
AZGS3 ;
S ACHSREF=ACHSGLBL_"("""_R_""","""_ACHSRR_""","_ACHSRRR_")",ACHSRRR=$O(@ACHSREF) G AZGS2:+ACHSRRR<1 S X=^(ACHSRRR),ACHSRRCT=ACHSRRR
D PADWRITE
G AZGS3
;
AZGSTJCL ;
;ACHS*3.1*23
;D PCCTJCL^ACHSPCC4:ACHSGCTR=1,DPSTJCL^ACHSPCC4:ACHSGCTR=5
D PCCTJCL^ACHSPCC4:ACHSGCTR=1,DPSTJCL^ACHSPCC4:(ACHSGCTR=5)!(ACHSGCTR=8)
I ACHSGCTR=2 D PCCTJCL^ACHSPCC4,FITJCL^ACHSPCC4
;U IO(0) W $J($S(ACHSRRCT>0:ACHSRRCT,1:RCTR),8)
Q
;
PADWRITE ;EP.
S:$L(X)<80 X=X_$J("",80-$L(X))
I $E(X,1,2)="7A" S ACHS7A=+$E(X,3,4),X=$S(ACHS7A=19:"HC",ACHS7A=20:"CO",1:"DO")_$E(X,3,80)
I $E(X,1,2)="7B" S X=$S(ACHS7A=19:"H2",ACHS7A=20:"C2",1:"D2")_$E(X,3,80)
;JVK/ITSC/9.1.04
;I $E(X,1,2)="7C" S X="D3"_$E(X,3,80)
I $E(X,1,2)="7C" S X=$S(ACHS7A=19:"H3",ACHS7A=20:"C3",1:"D3")_$E(X,3,80)
;
;2/1/2 pmf add universal reg ID record
;I $E(X,1,2)="7D" S X=$S(ACHS7A=19:"H3",ACHS7A=20:"C3",1:"D4")_$E(X,3,80) ; ACHS*3.1*3
I $E(X,1,2)="7D" S X=$S(ACHS7A=19:"H4",ACHS7A=20:"C4",1:"D4")_$E(X,3,80) ; ACHS*3.1*3
;
I $E(X,1,2)="7E" S X=$S(ACHS7A=19:"H5",ACHS7A=20:"C5",1:"D5")_$E(X,3,80) ; ACHS*3.1*11
I $E(X,1,2)="7F" S X=$S(ACHS7A=19:"H6",ACHS7A=20:"C6",1:"D6")_$E(X,3,80) ; ACHS*3.1*11
I $E(X,1,2)="7G" S X=$S(ACHS7A=19:"H7",ACHS7A=20:"C7",1:"D7")_$E(X,3,80) ; ACHS*3.1*11
I $E(X,1,2)="7H" S X=$S(ACHS7A=19:"H8",ACHS7A=20:"C8",1:"D8")_$E(X,3,80) ; ACHS*3.1*11
I $E(X,1,2)="7I" S X=$S(ACHS7A=19:"H9",ACHS7A=20:"C9",1:"D9")_$E(X,3,80) ; ACHS*3.1*11
I $E(X,1,2)="7J" S X=$S(ACHS7A=19:"H0",ACHS7A=20:"C0",1:"D0")_$E(X,3,80) ; ACHS*3.1*11
I $E(X,1,2)="7K" S X=$S(ACHS7A=19:"HA",ACHS7A=20:"C1",1:"D1")_$E(X,3,80) ; ACHS*3.1*11
I $E(X,1,2)="7L" S X=$S(ACHS7A=19:"HB",ACHS7A=20:"C2",1:"D2")_$E(X,3,80) ; ACHS*3.1*11
I $E(X,1,2)="7M" S X=$S(ACHS7A=19:"HD",ACHS7A=20:"C3",1:"D3")_$E(X,3,80) ; ACHS*3.1*11
;I $E(X,1,2)="7N" S X=$S(ACHS7A=19:"HF",ACHS7A=20:"C4",1:"D4")_$E(X,3,80) ; ACHS*3.1*11
I $E(X,1,2)="7X" S X=$S(ACHS7A=19:"HX",ACHS7A=20:"CX",1:"DX")_$E(X,3,80) ; ACHS*3.1*3
;
U IO
W X,!
;
;2/1/02 pmf we no longer will write empty H3, C3 or D4 records
;I $E(X,1,2)="H2" S X="H3" G PADWRITE ; ACHS*3.1*3
;I $E(X,1,2)="C2" S X="C3" G PADWRITE ; ACHS*3.1*3
;I $E(X,1,2)="D3" S X="D4" G PADWRITE ; ACHS*3.1*3
;
S ACHSTXRC=ACHSTXRC+1
I ACHSTXRC#100=0 U IO(0) W $J(ACHSTXRC,8)
Q:(ACHSGCTR>1)!($E(X)'="2")
; Make entry into Area PO transaction file, as a DHR.
D ADD^ACHSAOPO($E(X,16,25),"DHR",X)
Q
;
UFMS ;SAVE AND SEND FILE; ACHS*3.1*13 IHS/OIT/FCJ ADDED UFMS SECTION
S ACHSTXRC=+$E(^ACHSUFMS("COUNT"),15,18) Q:ACHSTXRC=0
U IO(0)
W !!,"Processing the ",ACHSGLBL," (",ACHSDESC,") transaction file."
S X=$E(DT,4,7)_$E(DT,2,3)
D NOW^%DTC S X=(%I(3)+1700)_$E(%,4,7)_"_"_$P(%,".",2)
S:$L(X)'=15 X=X_0
S X1=$P(^AUTTAREA($P(^AUTTLOC(DUZ(2),0),U,4),0),U,3)
S:X1="S" X1="X" ;ACHS*3.1*19
S XBFN="IHS_PO_CHSMIS_"_X1_"_"_X_".dat"
S ACHSEXFS="IHSPOCHSMIS"_X1_X_".dat",ACHSEXFS=$TR(ACHSEXFS,"_","")
S XBGL="ACHSUFMS",XBNAR="CONTRACT HEALTH UFMS export data",XBMED="F",XBFLT=1
S XBS1="ACHS UFMS B",XBQ="N"
;ACHS*3.1*21 CHANGED SETTING XBUF TO I ELSE AND ADDED TEST FOR OS
I $$AOP^ACHS(3,2)'="" S XBUF=$$AOP^ACHS(3,2)
E S XBUF=$S($$OS^ACHS=2:"c:\usr\spool\chsdata",1:"/usr/spool/chsdata")
D ^XBGSAVE ;Saves and sends global
D CLOSE
Q
;
;ITSC/SET/JVK ACHS*3.1*11 changed name of 638 export to chsstat
;OIT.IHS.FCJ ACHS*3.1*23 ADDED NEW STAT REC FOR ICD-10
GLOBS ;;ACHSGLBL;ACHSDESC;ACHSSUF
;;^ACHSPCC;DHR;DHR
;;^ACHSBCBS;BLUE CROSS/SHIELD;bcs
;;^ACHSAOVU;VENDOR RECORDS;aov
;;^ACHSAOPD;PAYMENT RECORDS;aop
;;^ACHSPIG;638 STATISTICAL DATA;stat;638 ; ACHS*3.1*11
;;^ACHSCORE;DHR for CORE;DHR
;;^ACHSUFMS;DHR records for UFMS;IHS ;ACHS*3.1*13 IHS/OIT/FCJ
;;^ACHSPG2;638 STATISTICAL DATA;stat;638 ; ACHS*3.1*23
ACHSPCC3 ; IHS/ITSC/PMF - CHS AREA SPLITOUT (3/5)(WRITE TO FLATFILES) ;
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**11,13,19,21,23**;JUN 11,2001;Build 43
+2 ;ACHS*3.1*3 add UID to NPRS data
+3 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Reinstate display filename.
+4 ;ITSC/SET/JVK ACHS*3.1*11 ADDED ADDITONAL RECORRDS FOR STAT PURPOSES
+5 ;ACHS*3.1*13 IHS/OIT/FCJ ADDED UFMS PROCESSING
+6 SET (ACHSFLG,ACHSGCTR)=0
+7 GOTO PCC4
+8 ;
START ;
+1 ;I ACHSGLBL="^ACHSBCBS",($$AOP^ACHS(2,8)=""!($$AOP^ACHS(2,8)="N")) G PCC4
+2 IF ACHSGCTR=1
IF ACHSCT2=0
GOTO PCC4
+3 SET X=$ORDER(@(ACHSGLBL_"(0)"))
+4 IF +X<1
GOTO PCC4
+5 IF +X="**"
GOTO PCC4
MSM ;
+1 USE IO(0)
+2 WRITE !!,"Processing the ",ACHSGLBL," (",ACHSDESC,") transaction file."
+3 SET ACHSMED="F"
+4 IF "Ff"[ACHSMED
DO UNIX
+5 IF $DATA(ACHSJFLG)
DO JOBABEND^ACHSPCC4
QUIT
PCC4 ;
+1 IF ACHSFLG
DO JOBABEND^ACHSPCC4
QUIT
+2 SET ACHSGCTR=ACHSGCTR+1
SET ACHSGLBL=$PIECE($TEXT(@"GLOBS"+ACHSGCTR),";",3)
SET ACHSDESC=$PIECE($TEXT(@"GLOBS"+ACHSGCTR),";",4)
SET ACHSSUF=$PIECE($TEXT(@"GLOBS"+ACHSGCTR),";",5)
+3 ;ACHS*3.1*13 IHS/OIT/FCJ
IF ACHSGLBL="^ACHSUFMS"
DO UFMS
GOTO PCC4
+4 IF ACHSGLBL']""
DO END^ACHSPCC4
QUIT
+5 ;I ACHSGLBL
+6 IF ACHSGLBL="^ACHSBCBS"
IF $$AOP^ACHS(2,8)="Y"
GOTO START
+7 ;ITSC/SET/JVK ACHS*3.1*11;ACHS*3.1*23
+8 ;I ACHSGLBL="^ACHSPIG" S ACHSSUF=ACHSSUF_$E($P(^AUTTLOC(DUZ(2),0),U,10),1,2)_"0000"
+9 IF (ACHSGLBL="^ACHSPIG")!(ACHSGLBL="^ACHSPG2")
SET ACHSSUF=ACHSSUF_$EXTRACT($PIECE(^AUTTLOC(DUZ(2),0),U,10),1,2)_"0000"
+10 IF '$ORDER(@(ACHSGLBL_"(0)"))
GOTO PCC4
+11 GOTO START
+12 ;
UNIX ;
+1 SET ACHSFAC=$PIECE(^AUTTLOC(DUZ(2),0),U,10)
+2 ;S ACHSCCTR="PCC"
+3 SET ACHSHDNM=ACHSSUF
+4 IF ACHSHDNM="DHR"
SET ACHSHDNM="DHRP"
+5 IF ACHSGLBL="^ACHSCORE"
SET ACHSHDNM="DHRC"
+6 SET ACHSPGNM="ACHS"
SET ACHSZIN=1
+7 DO FILESEL^ACHSEXUT
+8 IF $DATA(ACHSJFLG)
GOTO END
+9 SET ACHSZFN=ACHSEXFN
SET ACHSZIN=0
+10 ;ACHS*3.1*21 CHANGED FILE NAME TO ALLOW MORE THEN 1 EXPORT A DAY...
+11 SET X=$EXTRACT(DT,4,7)_$EXTRACT(DT,2,3)
+12 DO NOW^%DTC
SET X=(%I(3)+1700)_$EXTRACT(%,4,7)_"_"_$PIECE(%,".",2)
+13 SET $PIECE(ACHSZFN,".",2)=X
+14 DO OPENHFS^ACHSTCK1
+15 IF ACHSZZA
DO ERROR^ACHSTCK1
DO JOBABEND^ACHSPCC4
QUIT
+16 IF ACHSGCTR=1
SET ACHSDHRN=ACHSZFN
+17 SET IO=ACHSZDEV
+18 USE IO(0)
+19 ;W !,"Please Standby - Copying Data to File: " ;,!?10,ACHSEXFS;IHS/SET/GTH ACHS*3.1*5 12/06/2002
+20 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
WRITE !,"Please Standby - Copying Data to File: ",!?10,ACHSZFN
+21 DO AZGSAV1M
CLOSE ;EP
+1 DO ^%ZISC
+2 USE IO(0)
+3 WRITE !!?10,ACHSTXRC," Total Records Copied to Output Media",!
+4 DO RTRN^ACHS
DO TXLOGADD^ACHSTXUT
+5 IF ACHSY>0
GOTO NORMEND
+6 USE IO(0)
+7 ;ACHS*3.1*21 ADDED LINE FEED
WRITE !,*7,?5,"UNABLE TO POST ENTRY TO IHS DATA TRANSMISSION LOG - NOTIFY SUPERVISOR"
+8 SET ACHSFLG=1
+9 GOTO END
+10 ;
NORMEND ;
+1 IF $DATA(^AFSTXLOG(0))
Begin DoDot:1
+2 SET $PIECE(^AFSTXLOG(DUZ(2),1,ACHSY,0),U,3)=$$HTFM^XLFDT($HOROLOG)
+3 SET $PIECE(^AFSTXLOG(DUZ(2),1,ACHSY,0),U,4)="Y"
+4 IF $DATA(ACHSTXRC)
SET $PIECE(^AFSTXLOG(DUZ(2),1,ACHSY,0),U,2)=ACHSTXRC
+5 NEW DA,DIK
+6 SET DIK="^AFSTXLOG("_DUZ(2)_",1,"
SET DA(1)=DUZ(2)
SET DA=ACHSY
+7 DO IX^DIK
+8 QUIT
End DoDot:1
+9 ;
END ; Kill vars, post 1166 open doc, quit.
+1 KILL ACHS,ACHS7A,ACHSFAC,ACHSMSG,ACHSRCTR,ACHSRR,ACHSRRCT,X1,X2
+2 IF $DATA(ACHSJFLG)
QUIT
+3 IF '$LENGTH($TEXT(FRD^AFSLODF0))
QUIT
+4 IF $$AOP^ACHS(2,12)'="Y"
QUIT
+5 IF $GET(ACHSZFN)'["chsdh"
QUIT
+6 ; Post 1166 open document file.
+7 WRITE !,"Begin Posting DHR file to 1166 Open Document File..."
+8 SET AFSXPFN=ACHSDHRN
+9 DO FRD^AFSLODF0
+10 KILL AFSXPFN
+11 WRITE !,"End Posting DHR file to 1166 Open Document File..."
+12 QUIT
+13 ;
AZGSAV1M ;
+1 USE IO(0)
+2 DO WAIT^DICD
+3 SET DX=$X
SET DY=$Y
SET R="0"
SET (ACHSRCTR,ACHSRR,ACHSRRR,ACHSRRCT,ACHSRRRC,ACHSTXRC)=0
+4 IF ACHSGCTR=1
SET DY=DY+1
+5 WRITE !
AZGSHJCL ;
+1 ;ACHS*3.1*23 ADDED SECOND STAT FILE FOR ICD-10
+2 ;D PCCHJCL^ACHSPCC4:ACHSGCTR=1,DPSHJCL^ACHSPCC4:ACHSGCTR=5,FIHJCL^ACHSPCC4:ACHSGCTR=2
+3 IF ACHSGCTR=1
DO PCCHJCL^ACHSPCC4
IF (ACHSGCTR=5)!(ACHSGCTR=8)
DO DPSHJCL^ACHSPCC4
IF ACHSGCTR=2
DO FIHJCL^ACHSPCC4
AZGS1 ;
+1 SET ACHSREF=ACHSGLBL_"("""_R_""")"
SET R=$ORDER(@ACHSREF)
IF +R<1
GOTO AZGSTJCL
SET ACHSRCTR=+R
IF $DATA(^(R))<2
SET X=^(R)
DO PADWRITE
GOTO AZGS1
+2 SET ACHSRR=0
AZGS2 ;
+1 SET ACHSREF=ACHSGLBL_"("""_R_""","_ACHSRR_")"
SET ACHSRR=$ORDER(@ACHSREF)
IF +ACHSRR<1
GOTO AZGS1
IF $DATA(^(ACHSRR))<2
SET X=^(ACHSRR)
SET ACHSRRCT=ACHSRR
DO PADWRITE
GOTO AZGS2
+2 SET ACHSRRR=0
AZGS3 ;
+1 SET ACHSREF=ACHSGLBL_"("""_R_""","""_ACHSRR_""","_ACHSRRR_")"
SET ACHSRRR=$ORDER(@ACHSREF)
IF +ACHSRRR<1
GOTO AZGS2
SET X=^(ACHSRRR)
SET ACHSRRCT=ACHSRRR
+2 DO PADWRITE
+3 GOTO AZGS3
+4 ;
AZGSTJCL ;
+1 ;ACHS*3.1*23
+2 ;D PCCTJCL^ACHSPCC4:ACHSGCTR=1,DPSTJCL^ACHSPCC4:ACHSGCTR=5
+3 IF ACHSGCTR=1
DO PCCTJCL^ACHSPCC4
IF (ACHSGCTR=5)!(ACHSGCTR=8)
DO DPSTJCL^ACHSPCC4
+4 IF ACHSGCTR=2
DO PCCTJCL^ACHSPCC4
DO FITJCL^ACHSPCC4
+5 ;U IO(0) W $J($S(ACHSRRCT>0:ACHSRRCT,1:RCTR),8)
+6 QUIT
+7 ;
PADWRITE ;EP.
+1 IF $LENGTH(X)<80
SET X=X_$JUSTIFY("",80-$LENGTH(X))
+2 IF $EXTRACT(X,1,2)="7A"
SET ACHS7A=+$EXTRACT(X,3,4)
SET X=$SELECT(ACHS7A=19:"HC",ACHS7A=20:"CO",1:"DO")_$EXTRACT(X,3,80)
+3 IF $EXTRACT(X,1,2)="7B"
SET X=$SELECT(ACHS7A=19:"H2",ACHS7A=20:"C2",1:"D2")_$EXTRACT(X,3,80)
+4 ;JVK/ITSC/9.1.04
+5 ;I $E(X,1,2)="7C" S X="D3"_$E(X,3,80)
+6 IF $EXTRACT(X,1,2)="7C"
SET X=$SELECT(ACHS7A=19:"H3",ACHS7A=20:"C3",1:"D3")_$EXTRACT(X,3,80)
+7 ;
+8 ;2/1/2 pmf add universal reg ID record
+9 ;I $E(X,1,2)="7D" S X=$S(ACHS7A=19:"H3",ACHS7A=20:"C3",1:"D4")_$E(X,3,80) ; ACHS*3.1*3
+10 ; ACHS*3.1*3
IF $EXTRACT(X,1,2)="7D"
SET X=$SELECT(ACHS7A=19:"H4",ACHS7A=20:"C4",1:"D4")_$EXTRACT(X,3,80)
+11 ;
+12 ; ACHS*3.1*11
IF $EXTRACT(X,1,2)="7E"
SET X=$SELECT(ACHS7A=19:"H5",ACHS7A=20:"C5",1:"D5")_$EXTRACT(X,3,80)
+13 ; ACHS*3.1*11
IF $EXTRACT(X,1,2)="7F"
SET X=$SELECT(ACHS7A=19:"H6",ACHS7A=20:"C6",1:"D6")_$EXTRACT(X,3,80)
+14 ; ACHS*3.1*11
IF $EXTRACT(X,1,2)="7G"
SET X=$SELECT(ACHS7A=19:"H7",ACHS7A=20:"C7",1:"D7")_$EXTRACT(X,3,80)
+15 ; ACHS*3.1*11
IF $EXTRACT(X,1,2)="7H"
SET X=$SELECT(ACHS7A=19:"H8",ACHS7A=20:"C8",1:"D8")_$EXTRACT(X,3,80)
+16 ; ACHS*3.1*11
IF $EXTRACT(X,1,2)="7I"
SET X=$SELECT(ACHS7A=19:"H9",ACHS7A=20:"C9",1:"D9")_$EXTRACT(X,3,80)
+17 ; ACHS*3.1*11
IF $EXTRACT(X,1,2)="7J"
SET X=$SELECT(ACHS7A=19:"H0",ACHS7A=20:"C0",1:"D0")_$EXTRACT(X,3,80)
+18 ; ACHS*3.1*11
IF $EXTRACT(X,1,2)="7K"
SET X=$SELECT(ACHS7A=19:"HA",ACHS7A=20:"C1",1:"D1")_$EXTRACT(X,3,80)
+19 ; ACHS*3.1*11
IF $EXTRACT(X,1,2)="7L"
SET X=$SELECT(ACHS7A=19:"HB",ACHS7A=20:"C2",1:"D2")_$EXTRACT(X,3,80)
+20 ; ACHS*3.1*11
IF $EXTRACT(X,1,2)="7M"
SET X=$SELECT(ACHS7A=19:"HD",ACHS7A=20:"C3",1:"D3")_$EXTRACT(X,3,80)
+21 ;I $E(X,1,2)="7N" S X=$S(ACHS7A=19:"HF",ACHS7A=20:"C4",1:"D4")_$E(X,3,80) ; ACHS*3.1*11
+22 ; ACHS*3.1*3
IF $EXTRACT(X,1,2)="7X"
SET X=$SELECT(ACHS7A=19:"HX",ACHS7A=20:"CX",1:"DX")_$EXTRACT(X,3,80)
+23 ;
+24 USE IO
+25 WRITE X,!
+26 ;
+27 ;2/1/02 pmf we no longer will write empty H3, C3 or D4 records
+28 ;I $E(X,1,2)="H2" S X="H3" G PADWRITE ; ACHS*3.1*3
+29 ;I $E(X,1,2)="C2" S X="C3" G PADWRITE ; ACHS*3.1*3
+30 ;I $E(X,1,2)="D3" S X="D4" G PADWRITE ; ACHS*3.1*3
+31 ;
+32 SET ACHSTXRC=ACHSTXRC+1
+33 IF ACHSTXRC#100=0
USE IO(0)
WRITE $JUSTIFY(ACHSTXRC,8)
+34 IF (ACHSGCTR>1)!($EXTRACT(X)'="2")
QUIT
+35 ; Make entry into Area PO transaction file, as a DHR.
+36 DO ADD^ACHSAOPO($EXTRACT(X,16,25),"DHR",X)
+37 QUIT
+38 ;
UFMS ;SAVE AND SEND FILE; ACHS*3.1*13 IHS/OIT/FCJ ADDED UFMS SECTION
+1 SET ACHSTXRC=+$EXTRACT(^ACHSUFMS("COUNT"),15,18)
IF ACHSTXRC=0
QUIT
+2 USE IO(0)
+3 WRITE !!,"Processing the ",ACHSGLBL," (",ACHSDESC,") transaction file."
+4 SET X=$EXTRACT(DT,4,7)_$EXTRACT(DT,2,3)
+5 DO NOW^%DTC
SET X=(%I(3)+1700)_$EXTRACT(%,4,7)_"_"_$PIECE(%,".",2)
+6 IF $LENGTH(X)'=15
SET X=X_0
+7 SET X1=$PIECE(^AUTTAREA($PIECE(^AUTTLOC(DUZ(2),0),U,4),0),U,3)
+8 ;ACHS*3.1*19
IF X1="S"
SET X1="X"
+9 SET XBFN="IHS_PO_CHSMIS_"_X1_"_"_X_".dat"
+10 SET ACHSEXFS="IHSPOCHSMIS"_X1_X_".dat"
SET ACHSEXFS=$TRANSLATE(ACHSEXFS,"_","")
+11 SET XBGL="ACHSUFMS"
SET XBNAR="CONTRACT HEALTH UFMS export data"
SET XBMED="F"
SET XBFLT=1
+12 SET XBS1="ACHS UFMS B"
SET XBQ="N"
+13 ;ACHS*3.1*21 CHANGED SETTING XBUF TO I ELSE AND ADDED TEST FOR OS
+14 IF $$AOP^ACHS(3,2)'=""
SET XBUF=$$AOP^ACHS(3,2)
+15 IF '$TEST
SET XBUF=$SELECT($$OS^ACHS=2:"c:\usr\spool\chsdata",1:"/usr/spool/chsdata")
+16 ;Saves and sends global
DO ^XBGSAVE
+17 DO CLOSE
+18 QUIT
+19 ;
+20 ;ITSC/SET/JVK ACHS*3.1*11 changed name of 638 export to chsstat
+21 ;OIT.IHS.FCJ ACHS*3.1*23 ADDED NEW STAT REC FOR ICD-10
GLOBS ;;ACHSGLBL;ACHSDESC;ACHSSUF
+1 ;;^ACHSPCC;DHR;DHR
+2 ;;^ACHSBCBS;BLUE CROSS/SHIELD;bcs
+3 ;;^ACHSAOVU;VENDOR RECORDS;aov
+4 ;;^ACHSAOPD;PAYMENT RECORDS;aop
+5 ;;^ACHSPIG;638 STATISTICAL DATA;stat;638 ; ACHS*3.1*11
+6 ;;^ACHSCORE;DHR for CORE;DHR
+7 ;;^ACHSUFMS;DHR records for UFMS;IHS ;ACHS*3.1*13 IHS/OIT/FCJ
+8 ;;^ACHSPG2;638 STATISTICAL DATA;stat;638 ; ACHS*3.1*23
