ACHSTX5 ; IHS/ITSC/PMF - EXPORT DATA (6/9) - RECORD 5(DOCUMENT FOR AO/FI) ;JUL 10, 2008
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**4,6,13,14,16,19**;JUN 11,2001
;ACHS*3.1*4 include URRID in the 5C record
;ACHS*3.1*6 ADDED FI MESSAGE APPROVAL FIELDS
;ACHS*3.1*13 6.6.2007 IHS/OIT/FCJ Fixed rec lngth if FI message sent for BLANKETS
;ACHS*3.1*14 1.7.2008 IHS/OIT/FCJ Changed unique pt reg id to use unique DB ID
;ACHS*3.1*16 10.16.2009 IHS.OIT.FCJ FX FY FIELD
;
I $$PARM^ACHS(2,11)'="Y" G END
W !!?10,"BUILDING ",$$REC^ACHSACO1(5)," : ",!?9
S ACHSDB=$S($$GET1^DIQ(9999999.06,DUZ(2),.32)=17121:1,1:" ") ;ACHS*3.1*19 NEW LINE TO IDENT DB
S R=0
C1 ;
S R=$O(^ACHSTXOB(R))
G END:'R
S ACHSRR=0,ACHSDOCR=$G(^ACHSF(DUZ(2),"D",R,0))
C2 ;
S ACHSRR=$O(^ACHSTXOB(R,ACHSRR))
G C1:'ACHSRR
;
;for test
S SDA=ACHSRR
;
S ACHSTRAN=$G(^ACHSF(DUZ(2),"D",R,"T",ACHSRR,0))
;ACHS*3.1*16 10/15/2009 IHS.OIT.FCJ ADDED CORRECT FY
;S ACHSDOCN="0"_$P(ACHSDOCR,U,14)_ACHSFC_$E($P(ACHSDOCR,U)+100000,2,6)
S ACHSDOCN=$E($P(ACHSDOCR,U,27),3,4)_ACHSFC_$E($P(ACHSDOCR,U)+100000,2,6)
D TOS^ACHSTX8
S ACHSFAC=ACHSAFAC,ACHSREFT=" "
S:$D(^ACHSF(DUZ(2),"D",R,3)) ACHSREFT=$P($G(^ACHSF(DUZ(2),"D",R,3)),U,10)
S ACHSREFT=$E(" "_ACHSREFT_" ",1,2),(ACHSEDOS,ACHSFRDT,ACHSTODT)=$J(" ",6)
S (ACHSEDOS("5C"),ACHSFRDT("5C"),ACHSTODT("5C"))=$J(" ",8)
G C3:'$D(^ACHSF(DUZ(2),"D",R,3))
S X=$G(^ACHSF(DUZ(2),"D",R,3))
;
S:+$P(X,U,9)>0 ACHSEDOS=$E($P(X,U,9),2,7),ACHSEDOS("5C")=17000000+$P(X,U,9)
S:+$P(X,U,1)>0 ACHSFRDT=$E($P(X,U,1),2,7),ACHSFRDT("5C")=17000000+$P(X,U,1)
S:+$P(X,U,2)>0 ACHSTODT=$E($P(X,U,2),2,7),ACHSTODT("5C")=17000000+$P(X,U,2)
C3 ;
S X=$P(ACHSDOCR,U,3),ACHSBIND=$S(X=1:"Y",X=0:"N",1:" "),X=$P(ACHSDOCR,U,8),ACHSEIN=$P($G(^AUTTVNDR(X,11)),U)_$P($G(^(11)),U,2),ACHSFED=$S($P($G(^(11)),U,10)=2:2,1:1),ACHSEIN=$E(ACHSEIN_$J("",12),1,12)
S X=$P(ACHSDOCR,U,21)
I +X>0 S ACHSHRN=X G C5
S X=$P(ACHSTRAN,U,3)
I +X<1 S ACHSHRN="" G C5
S ACHSHRN=$$HRN^ACHS(X,DUZ(2))
C5 ;
S ACHSHRN=$E(ACHSHRN+1000000,2,7),X=$P(ACHSDOCR,U,5),ACHSPROV=$P(ACHSDOCR,U,8),ACHSCN=$J("",10)
G C5A:+X=0,C5A:'$D(^AUTTVNDR(ACHSPROV,"CN",+X,0))
S Z="",ACHSCN=$P($G(^AUTTVNDR(ACHSPROV,"CN",+X,0)),U)
F ACHSI=1:1:$L(ACHSCN) I $E(ACHSCN,ACHSI,ACHSI)?1N S Z=Z_$E(ACHSCN,ACHSI,ACHSI)
I $F("235^239^241^242^243^244^245^246^247^248^249^285",$E(Z,1,3)) S ACHSCN=$E(Z_$J("",10),1,10) G C6
S ACHSCN=$E(ACHSARCO_Z_$J("",10),1,10)
G C6
;
C5A ;
S X=$P(ACHSDOCR,U,23)
G C6:+X=0,C6:'$D(^AUTTVNDR(ACHSPROV,18,X,0))
S Y=$G(^AUTTVNDR(ACHSPROV,18,X,0)),Z=$P(Y,U,10),W=$E($P(Y,U,1),1,2)_$S(Z="PA":"PA",Z="RQ":"R",Z="BPA":"A",1:""),X=$E($P(Y,U,1),3,6)
S:Z'="PA" W=W_$E(X,1,4)
S:Z="PA" W=W_$E(X,2,4)
S ACHSCN=$E(ACHSARCO_W_$J("",10),1,10),ACHSREFT=" "
C6 ;
D CANOBJ^ACHSTX8
S (X,ACHSTYPE)=$P(ACHSTRAN,U,2)
S:'$L(X) X=" "
S ACHSSTS=X_" "
I ACHSSTS="C " S X=$P(ACHSDOCR,U,12),ACHSSTS=$E(ACHSSTS)_$S((X=2)!(X=3):"P",X=4:"A",1:" ")
D IPA^ACHSTX8
S ACHSIPA=$E(ACHSIPA,5,12)
I ACHSTYPE="C" S ACHSIPA="-"_$E(ACHSIPA,2,8)
S ACHSESDA=$S($D(^ACHSF(DUZ(2),"D",R,1)):$P(^(1),U),1:""),ACHSESDA=$E(1000+ACHSESDA,2,4),ACHSRCT=ACHSRCT+1,ACHSRTYP(5)=ACHSRTYP(5)+1
I ACHSCN=$J("",10) S ACHSCN="OM"_$J("",8),ACHSCN=$E(ACHSCN,1,10)
S ^ACHSDATA(ACHSRCT)="5A"_ACHSDOCN_ACHSTOS2_ACHSFAC_ACHSBIND_ACHSEIN_ACHSHRN_ACHSCN_ACHSCAN_ACHSOBJC_$E($P(ACHSDOCR,U,2),2,7)_ACHSSTS_ACHSIPA_ACHSESDA_ACHSFED
;
C7 ; Build Patient name & 3rd party info for 5B record.
S ACHSRCT=ACHSRCT+1,ACHSRTYP(5)=ACHSRTYP(5)+1
;
D ADD5B
S ^ACHSDATA(ACHSRCT)="5B"_ACHSREFT_ACHSEDOS_ACHSFRDT_ACHSTODT_ACHSPATN_ACHS5IN1_ACHS5IN2_ACHSTRIB_ACHSCOMM
;
S ACHSRCT=ACHSRCT+1,ACHSRTYP(5)=ACHSRTYP(5)+1
;
;ACHS*3.1*4 3/27/02 pmf add UID to this trans
;S ^ACHSDATA(ACHSRCT)="5C"_ACHSSCC_($P(ACHSDOCR,U,2)+17000000)_ACHSEDOS("5C")_ACHSFRDT("5C")_ACHSTODT("5C")_$J("",42) ; ACHS*3.1*4
;IHS/SET/JVK ACHS*3.1*6 4/23/03 ADD THE FIELD FOR STERILIZATION AND IN SUPPORT OF DIRECT CARE FIELD FOR FI
D FIMSG ; ACHS*3.1*6
S X="" S:DFN="" X=" " ;ACHS*3.1*13 IHS/OIT/FCJ ADDED FOR BLANKETS
;ACHS*3.1*14 IHS/OIT/FCJ CHNG THE REG ID TO USE UNQ DBID;ACHS*3.1*19 ADDED DB ID FLG
S ACHSAGID=$$GET1^DIQ(9999999.06,$P(^AUTTSITE(1,0),U),.32)_($E("0000000000",1,10-$L(DFN))_DFN)_" "
;S ACHS5C="5C"_ACHSSCC_($P(ACHSDOCR,U,2)+17000000)_ACHSEDOS("5C")_ACHSFRDT("5C")_ACHSTODT("5C")_$$UID^AGTXID(DFN)_X_ACHSSAP_ACHSDAP_$J("",42) ; ACHS*3.1*6
S ACHS5C="5C"_ACHSSCC_($P(ACHSDOCR,U,2)+17000000)_ACHSEDOS("5C")_ACHSFRDT("5C")_ACHSTODT("5C")_ACHSAGID_X_ACHSSAP_ACHSDAP_ACHSDB_$J("",41) ; ACHS*3.1*6;ACHS*3.1*19
S ^ACHSDATA(ACHSRCT)=$E(ACHS5C,1,80) ; ACHS*3.1*4
;S PMFF=^ACHSDATA(ACHSRCT) D ^ACHSTX99 ; ACHS*3.1*4
;
I '(ACHSRTYP(5)#10) W $J(ACHSRTYP(5),8)
G C2
;
END ; Kill vars, go to *TX6.
K ACHSAGID,ACHSIPA,ACHSBIND,ACHSCAN,ACHSCN,ACHSESDA,ACHSEIN,ACHSFAC,ACHSFED,ACHSHRN,ACHSDOCN,ACHSPATN,ACHSSTS,ACHSTOS,ACHSSCC,ACHSSCC,ACHSTRAN,ACHSTYPE,ACHSPROV,W,X,Y,Z
;
;ACHS*3.1*4 4/4/02 pmf kill this scratch var
K ACHS5C ; ACHS*3.1*4
;IHS/SET/JVK ACHS*3.1*6 4/23/2003 KILL VARS
K ACHSSAP,ACHSDAP,VAL,I ;ACHS*3.1*6
;
S ACHSROUT=ACHSRCT
G ^ACHSTX6
;
ADD5B ; Add Patient Name & Ins info to 5B record.
S DFN=$P(ACHSDOCR,U,22),ACHSPATN=$J(" ",16),ACHSCOMM=$J(" ",7),ACHSTRIB=$J(" ",3)
I +DFN<1 G ADD5B2
ADD5B1 ;
S:$D(^DPT(DFN)) ACHSPATN=$E($P($G(^DPT(DFN,0)),U)_$J(" ",16),1,16)
D TRIB^ACHSTX8
S ACHSCOMM=$J(" ",7)
I $P($G(^AUPNPAT(DFN,11)),U,18)]"",$D(^AUTTCOM("B",$P($G(^(11)),U,18))) S ACHSCOMM=$P(^AUTTCOM($O(^AUTTCOM("B",$P(^AUPNPAT(DFN,11),U,18),0)),0),U,8),ACHSCOMM=$E(ACHSCOMM,5,7)_$E(ACHSCOMM,3,4)_$E(ACHSCOMM,1,2)
ADD5B2 ;
K ACHS3C,ACHS5IN1,ACHS5IN2,ACHSX18,ACHSX19
S ACHSZZI=1,(ACHSX18,ACHSX19,ACHSDEST,ACHS5IN1,ACHS5IN2)="",ACHSR=DFN,ACHS3CFL=0
D ^ACHSTX3C:+DFN>0
ADD5BA ;
G ADD5BZ:ACHSZZI>ACHS3CFL
S X=ACHS3C(ACHSZZI)
S:$E(X,3,10)="MEDICARE" ACHSX18=ACHSX18_$E(X,64,64)_" ",ACHSX18(18)=ACHSZZI
S:$E(X,3,10)="MEDICAID" ACHSX19=ACHSX19_$E(X,48,49)_" ",ACHSX19(19)=ACHSZZI
I '$D(ACHSX18(18)) S ACHS5IN1=$E(X,3,22),ACHSX18(18)=ACHSZZI G ADD5BC
S:'$D(ACHSX19(19)) ACHS5IN2=$E(X,3,22),ACHSX19(19)=ACHSZZI
ADD5BC ;
S ACHSZZI=ACHSZZI+1
G ADD5BA
;
ADD5BZ ; Write 5B new parts.
S:ACHSX18'="" ACHS5IN1=$E(ACHS3C(ACHSX18(18)),3,10)_" "_ACHSX18
S:ACHSX19'="" ACHS5IN2=$E(ACHS3C(ACHSX19(19)),3,10)_" "_ACHSX19
S ACHS5IN1=$E(ACHS5IN1_$J(" ",16),1,16),ACHS5IN2=$E(ACHS5IN2_$J(" ",16),1,16)
K ACHSZZI
Q
;
FIMSG ;TEST IF THERE IS AN APPROVAL MESSAGE FOR FI
S I=0
S (ACHSDAP,ACHSSAP)=""
F S I=$O(^ACHSF(DUZ(2),"D",R,102,I)) Q:I'?1N.N D
. S VAL(I)=$P(^ACHSF(DUZ(2),"D",R,102,I,0),U)
. I VAL(I)="S" S ACHSSAP="Y"
. I VAL(I)="D" S ACHSDAP="Y"
S ACHSSAP=$S(ACHSSAP="Y":"Y",ACHSSAP="":" ")
S ACHSDAP=$S(ACHSDAP="Y":"Y",ACHSDAP="":" ")
Q
ACHSTX5 ; IHS/ITSC/PMF - EXPORT DATA (6/9) - RECORD 5(DOCUMENT FOR AO/FI) ;JUL 10, 2008
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**4,6,13,14,16,19**;JUN 11,2001
+2 ;ACHS*3.1*4 include URRID in the 5C record
+3 ;ACHS*3.1*6 ADDED FI MESSAGE APPROVAL FIELDS
+4 ;ACHS*3.1*13 6.6.2007 IHS/OIT/FCJ Fixed rec lngth if FI message sent for BLANKETS
+5 ;ACHS*3.1*14 1.7.2008 IHS/OIT/FCJ Changed unique pt reg id to use unique DB ID
+6 ;ACHS*3.1*16 10.16.2009 IHS.OIT.FCJ FX FY FIELD
+7 ;
+8 IF $$PARM^ACHS(2,11)'="Y"
GOTO END
+9 WRITE !!?10,"BUILDING ",$$REC^ACHSACO1(5)," : ",!?9
+10 ;ACHS*3.1*19 NEW LINE TO IDENT DB
SET ACHSDB=$SELECT($$GET1^DIQ(9999999.06,DUZ(2),.32)=17121:1,1:" ")
+11 SET R=0
C1 ;
+1 SET R=$ORDER(^ACHSTXOB(R))
+2 IF 'R
GOTO END
+3 SET ACHSRR=0
SET ACHSDOCR=$GET(^ACHSF(DUZ(2),"D",R,0))
C2 ;
+1 SET ACHSRR=$ORDER(^ACHSTXOB(R,ACHSRR))
+2 IF 'ACHSRR
GOTO C1
+3 ;
+4 ;for test
+5 SET SDA=ACHSRR
+6 ;
+7 SET ACHSTRAN=$GET(^ACHSF(DUZ(2),"D",R,"T",ACHSRR,0))
+8 ;ACHS*3.1*16 10/15/2009 IHS.OIT.FCJ ADDED CORRECT FY
+9 ;S ACHSDOCN="0"_$P(ACHSDOCR,U,14)_ACHSFC_$E($P(ACHSDOCR,U)+100000,2,6)
+10 SET ACHSDOCN=$EXTRACT($PIECE(ACHSDOCR,U,27),3,4)_ACHSFC_$EXTRACT($PIECE(ACHSDOCR,U)+100000,2,6)
+11 DO TOS^ACHSTX8
+12 SET ACHSFAC=ACHSAFAC
SET ACHSREFT=" "
+13 IF $DATA(^ACHSF(DUZ(2),"D",R,3))
SET ACHSREFT=$PIECE($GET(^ACHSF(DUZ(2),"D",R,3)),U,10)
+14 SET ACHSREFT=$EXTRACT(" "_ACHSREFT_" ",1,2)
SET (ACHSEDOS,ACHSFRDT,ACHSTODT)=$JUSTIFY(" ",6)
+15 SET (ACHSEDOS("5C"),ACHSFRDT("5C"),ACHSTODT("5C"))=$JUSTIFY(" ",8)
+16 IF '$DATA(^ACHSF(DUZ(2),"D",R,3))
GOTO C3
+17 SET X=$GET(^ACHSF(DUZ(2),"D",R,3))
+18 ;
+19 IF +$PIECE(X,U,9)>0
SET ACHSEDOS=$EXTRACT($PIECE(X,U,9),2,7)
SET ACHSEDOS("5C")=17000000+$PIECE(X,U,9)
+20 IF +$PIECE(X,U,1)>0
SET ACHSFRDT=$EXTRACT($PIECE(X,U,1),2,7)
SET ACHSFRDT("5C")=17000000+$PIECE(X,U,1)
+21 IF +$PIECE(X,U,2)>0
SET ACHSTODT=$EXTRACT($PIECE(X,U,2),2,7)
SET ACHSTODT("5C")=17000000+$PIECE(X,U,2)
C3 ;
+1 SET X=$PIECE(ACHSDOCR,U,3)
SET ACHSBIND=$SELECT(X=1:"Y",X=0:"N",1:" ")
SET X=$PIECE(ACHSDOCR,U,8)
SET ACHSEIN=$PIECE($GET(^AUTTVNDR(X,11)),U)_$PIECE($GET(^(11)),U,2)
SET ACHSFED=$SELECT($PIECE($GET(^(11)),U,10)=2:2,1:1)
SET ACHSEIN=$EXTRACT(ACHSEIN_$JUSTIFY("",12),1,12)
+2 SET X=$PIECE(ACHSDOCR,U,21)
+3 IF +X>0
SET ACHSHRN=X
GOTO C5
+4 SET X=$PIECE(ACHSTRAN,U,3)
+5 IF +X<1
SET ACHSHRN=""
GOTO C5
+6 SET ACHSHRN=$$HRN^ACHS(X,DUZ(2))
C5 ;
+1 SET ACHSHRN=$EXTRACT(ACHSHRN+1000000,2,7)
SET X=$PIECE(ACHSDOCR,U,5)
SET ACHSPROV=$PIECE(ACHSDOCR,U,8)
SET ACHSCN=$JUSTIFY("",10)
+2 IF +X=0
GOTO C5A
IF '$DATA(^AUTTVNDR(ACHSPROV,"CN",+X,0))
GOTO C5A
+3 SET Z=""
SET ACHSCN=$PIECE($GET(^AUTTVNDR(ACHSPROV,"CN",+X,0)),U)
+4 FOR ACHSI=1:1:$LENGTH(ACHSCN)
IF $EXTRACT(ACHSCN,ACHSI,ACHSI)?1N
SET Z=Z_$EXTRACT(ACHSCN,ACHSI,ACHSI)
+5 IF $FIND("235^239^241^242^243^244^245^246^247^248^249^285",$EXTRACT(Z,1,3))
SET ACHSCN=$EXTRACT(Z_$JUSTIFY("",10),1,10)
GOTO C6
+6 SET ACHSCN=$EXTRACT(ACHSARCO_Z_$JUSTIFY("",10),1,10)
+7 GOTO C6
+8 ;
C5A ;
+1 SET X=$PIECE(ACHSDOCR,U,23)
+2 IF +X=0
GOTO C6
IF '$DATA(^AUTTVNDR(ACHSPROV,18,X,0))
GOTO C6
+3 SET Y=$GET(^AUTTVNDR(ACHSPROV,18,X,0))
SET Z=$PIECE(Y,U,10)
SET W=$EXTRACT($PIECE(Y,U,1),1,2)_$SELECT(Z="PA":"PA",Z="RQ":"R",Z="BPA":"A",1:"")
SET X=$EXTRACT($PIECE(Y,U,1),3,6)
+4 IF Z'="PA"
SET W=W_$EXTRACT(X,1,4)
+5 IF Z="PA"
SET W=W_$EXTRACT(X,2,4)
+6 SET ACHSCN=$EXTRACT(ACHSARCO_W_$JUSTIFY("",10),1,10)
SET ACHSREFT=" "
C6 ;
+1 DO CANOBJ^ACHSTX8
+2 SET (X,ACHSTYPE)=$PIECE(ACHSTRAN,U,2)
+3 IF '$LENGTH(X)
SET X=" "
+4 SET ACHSSTS=X_" "
+5 IF ACHSSTS="C "
SET X=$PIECE(ACHSDOCR,U,12)
SET ACHSSTS=$EXTRACT(ACHSSTS)_$SELECT((X=2)!(X=3):"P",X=4:"A",1:" ")
+6 DO IPA^ACHSTX8
+7 SET ACHSIPA=$EXTRACT(ACHSIPA,5,12)
+8 IF ACHSTYPE="C"
SET ACHSIPA="-"_$EXTRACT(ACHSIPA,2,8)
+9 SET ACHSESDA=$SELECT($DATA(^ACHSF(DUZ(2),"D",R,1)):$PIECE(^(1),U),1:"")
SET ACHSESDA=$EXTRACT(1000+ACHSESDA,2,4)
SET ACHSRCT=ACHSRCT+1
SET ACHSRTYP(5)=ACHSRTYP(5)+1
+10 IF ACHSCN=$JUSTIFY("",10)
SET ACHSCN="OM"_$JUSTIFY("",8)
SET ACHSCN=$EXTRACT(ACHSCN,1,10)
+11 SET ^ACHSDATA(ACHSRCT)="5A"_ACHSDOCN_ACHSTOS2_ACHSFAC_ACHSBIND_ACHSEIN_ACHSHRN_ACHSCN_ACHSCAN_ACHSOBJC_$EXTRACT($PIECE(ACHSDOCR,U,2),2,7)_ACHSSTS_ACHSIPA_ACHSESDA_ACHSFED
+12 ;
C7 ; Build Patient name & 3rd party info for 5B record.
+1 SET ACHSRCT=ACHSRCT+1
SET ACHSRTYP(5)=ACHSRTYP(5)+1
+2 ;
+3 DO ADD5B
+4 SET ^ACHSDATA(ACHSRCT)="5B"_ACHSREFT_ACHSEDOS_ACHSFRDT_ACHSTODT_ACHSPATN_ACHS5IN1_ACHS5IN2_ACHSTRIB_ACHSCOMM
+5 ;
+6 SET ACHSRCT=ACHSRCT+1
SET ACHSRTYP(5)=ACHSRTYP(5)+1
+7 ;
+8 ;ACHS*3.1*4 3/27/02 pmf add UID to this trans
+9 ;S ^ACHSDATA(ACHSRCT)="5C"_ACHSSCC_($P(ACHSDOCR,U,2)+17000000)_ACHSEDOS("5C")_ACHSFRDT("5C")_ACHSTODT("5C")_$J("",42) ; ACHS*3.1*4
+10 ;IHS/SET/JVK ACHS*3.1*6 4/23/03 ADD THE FIELD FOR STERILIZATION AND IN SUPPORT OF DIRECT CARE FIELD FOR FI
+11 ; ACHS*3.1*6
DO FIMSG
+12 ;ACHS*3.1*13 IHS/OIT/FCJ ADDED FOR BLANKETS
SET X=""
IF DFN=""
SET X=" "
+13 ;ACHS*3.1*14 IHS/OIT/FCJ CHNG THE REG ID TO USE UNQ DBID;ACHS*3.1*19 ADDED DB ID FLG
+14 SET ACHSAGID=$$GET1^DIQ(9999999.06,$PIECE(^AUTTSITE(1,0),U),.32)_($EXTRACT("0000000000",1,10-$LENGTH(DFN))_DFN)_" "
+15 ;S ACHS5C="5C"_ACHSSCC_($P(ACHSDOCR,U,2)+17000000)_ACHSEDOS("5C")_ACHSFRDT("5C")_ACHSTODT("5C")_$$UID^AGTXID(DFN)_X_ACHSSAP_ACHSDAP_$J("",42) ; ACHS*3.1*6
+16 ; ACHS*3.1*6;ACHS*3.1*19
SET ACHS5C="5C"_ACHSSCC_($PIECE(ACHSDOCR,U,2)+17000000)_ACHSEDOS("5C")_ACHSFRDT("5C")_ACHSTODT("5C")_ACHSAGID_X_ACHSSAP_ACHSDAP_ACHSDB_$JUSTIFY("",41)
+17 ; ACHS*3.1*4
SET ^ACHSDATA(ACHSRCT)=$EXTRACT(ACHS5C,1,80)
+18 ;S PMFF=^ACHSDATA(ACHSRCT) D ^ACHSTX99 ; ACHS*3.1*4
+19 ;
+20 IF '(ACHSRTYP(5)#10)
WRITE $JUSTIFY(ACHSRTYP(5),8)
+21 GOTO C2
+22 ;
END ; Kill vars, go to *TX6.
+1 KILL ACHSAGID,ACHSIPA,ACHSBIND,ACHSCAN,ACHSCN,ACHSESDA,ACHSEIN,ACHSFAC,ACHSFED,ACHSHRN,ACHSDOCN,ACHSPATN,ACHSSTS,ACHSTOS,ACHSSCC,ACHSSCC,ACHSTRAN,ACHSTYPE,ACHSPROV,W,X,Y,Z
+2 ;
+3 ;ACHS*3.1*4 4/4/02 pmf kill this scratch var
+4 ; ACHS*3.1*4
KILL ACHS5C
+5 ;IHS/SET/JVK ACHS*3.1*6 4/23/2003 KILL VARS
+6 ;ACHS*3.1*6
KILL ACHSSAP,ACHSDAP,VAL,I
+7 ;
+8 SET ACHSROUT=ACHSRCT
+9 GOTO ^ACHSTX6
+10 ;
ADD5B ; Add Patient Name & Ins info to 5B record.
+1 SET DFN=$PIECE(ACHSDOCR,U,22)
SET ACHSPATN=$JUSTIFY(" ",16)
SET ACHSCOMM=$JUSTIFY(" ",7)
SET ACHSTRIB=$JUSTIFY(" ",3)
+2 IF +DFN<1
GOTO ADD5B2
ADD5B1 ;
+1 IF $DATA(^DPT(DFN))
SET ACHSPATN=$EXTRACT($PIECE($GET(^DPT(DFN,0)),U)_$JUSTIFY(" ",16),1,16)
+2 DO TRIB^ACHSTX8
+3 SET ACHSCOMM=$JUSTIFY(" ",7)
+4 IF $PIECE($GET(^AUPNPAT(DFN,11)),U,18)]""
IF $DATA(^AUTTCOM("B",$PIECE($GET(^(11)),U,18)))
SET ACHSCOMM=$PIECE(^AUTTCOM($ORDER(^AUTTCOM("B",$PIECE(^AUPNPAT(DFN,11),U,18),0)),0),U,8)
SET ACHSCOMM=$EXTRACT(ACHSCOMM,5,7)_$EXTRACT(ACHSCOMM,3,4)_$EXTRACT(ACHSCOMM,1,2)
ADD5B2 ;
+1 KILL ACHS3C,ACHS5IN1,ACHS5IN2,ACHSX18,ACHSX19
+2 SET ACHSZZI=1
SET (ACHSX18,ACHSX19,ACHSDEST,ACHS5IN1,ACHS5IN2)=""
SET ACHSR=DFN
SET ACHS3CFL=0
+3 IF +DFN>0
DO ^ACHSTX3C
ADD5BA ;
+1 IF ACHSZZI>ACHS3CFL
GOTO ADD5BZ
+2 SET X=ACHS3C(ACHSZZI)
+3 IF $EXTRACT(X,3,10)="MEDICARE"
SET ACHSX18=ACHSX18_$EXTRACT(X,64,64)_" "
SET ACHSX18(18)=ACHSZZI
+4 IF $EXTRACT(X,3,10)="MEDICAID"
SET ACHSX19=ACHSX19_$EXTRACT(X,48,49)_" "
SET ACHSX19(19)=ACHSZZI
+5 IF '$DATA(ACHSX18(18))
SET ACHS5IN1=$EXTRACT(X,3,22)
SET ACHSX18(18)=ACHSZZI
GOTO ADD5BC
+6 IF '$DATA(ACHSX19(19))
SET ACHS5IN2=$EXTRACT(X,3,22)
SET ACHSX19(19)=ACHSZZI
ADD5BC ;
+1 SET ACHSZZI=ACHSZZI+1
+2 GOTO ADD5BA
+3 ;
ADD5BZ ; Write 5B new parts.
+1 IF ACHSX18'=""
SET ACHS5IN1=$EXTRACT(ACHS3C(ACHSX18(18)),3,10)_" "_ACHSX18
+2 IF ACHSX19'=""
SET ACHS5IN2=$EXTRACT(ACHS3C(ACHSX19(19)),3,10)_" "_ACHSX19
+3 SET ACHS5IN1=$EXTRACT(ACHS5IN1_$JUSTIFY(" ",16),1,16)
SET ACHS5IN2=$EXTRACT(ACHS5IN2_$JUSTIFY(" ",16),1,16)
+4 KILL ACHSZZI
+5 QUIT
+6 ;
FIMSG ;TEST IF THERE IS AN APPROVAL MESSAGE FOR FI
+1 SET I=0
+2 SET (ACHSDAP,ACHSSAP)=""
+3 FOR
SET I=$ORDER(^ACHSF(DUZ(2),"D",R,102,I))
IF I'?1N.N
QUIT
Begin DoDot:1
+4 SET VAL(I)=$PIECE(^ACHSF(DUZ(2),"D",R,102,I,0),U)
+5 IF VAL(I)="S"
SET ACHSSAP="Y"
+6 IF VAL(I)="D"
SET ACHSDAP="Y"
End DoDot:1
+7 SET ACHSSAP=$SELECT(ACHSSAP="Y":"Y",ACHSSAP="":" ")
+8 SET ACHSDAP=$SELECT(ACHSDAP="Y":"Y",ACHSDAP="":" ")
+9 QUIT
