ACHSTX55 ; IHS/ADC/GTH - EXPORT DATA (6/9) - RECORD 5(DOCUMENT FOR AO/FI) ;
;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
;
;
;we can be 638, or have parm 2,9 set, but not both
I ACHSF638="Y",(ACHSF209) S RET=2 Q
I ACHSTY="P" S RET=3 Q
I 'ACHSF211 S RET=4 Q
;
S ACHSFAC=ACHSAFAC,ACHSREFT=" "
;
S:$D(^ACHSF(DUZ(2),"D",ACHSDIEN,3)) ACHSREFT=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,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",ACHSDIEN,3))
S X=^ACHSF(DUZ(2),"D",ACHSDIEN,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 ACHSBIND=$S(BLNKT=1:"Y",BLNKT=0:"N",BLNKT:" ")
;
I +CHART>0 S ACHSHRN=CHART 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)
;
D SETCN S ACHSCN=$E(ACHSCN_$J("",10),1,10)
;
C6 ;
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=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,1)),ACHSESDA=$E(1000+ACHSESDA,2,4),ACHSRCT=ACHSRCT+1,ACHSRTYP(5)=ACHSRTYP(5)+1
;
S VNDEINSX=VNDEINSF I VNDEINSX="" S VNDEINSX=" "
;
S ^ACHSTXOB(ACHSRCT)="5A"_ACHSDOCN_TYPSER2_ACHSAFAC_ACHSBIND_VNDEIN_VNDEINSX_ACHSHRN_ACHSCN_CAN_OCC_$E(ORDDAT,2,7)_ACHSSTS_ACHSIPA_ACHSESDA_VNDFNFC
;
S PMFF=^ACHSTXOB(ACHSRCT) D ^ACHSTX99
;
C7 ; Build Patient name & 3rd party info for 5B record.
S ACHSRCT=ACHSRCT+1,ACHSRTYP(5)=ACHSRTYP(5)+1
D ADD5B
;
S ^ACHSTXOB(ACHSRCT)="5B"_ACHSREFT_ACHSEDOS_ACHSFRDT_ACHSTODT_ACHSPATN_ACHS5IN1_ACHS5IN2_TRIBE_ACHSCOMM
;
S PMFF=^ACHSTXOB(ACHSRCT) D ^ACHSTX99
;
S ACHSRCT=ACHSRCT+1,ACHSRTYP(5)=ACHSRTYP(5)+1
S ^ACHSTXOB(ACHSRCT)="5C"_SCC_($P(ACHSDOCR,U,2)+17000000)_ACHSEDOS("5C")_ACHSFRDT("5C")_ACHSTODT("5C")_$J("",42)
;
S PMFF=^ACHSTXOB(ACHSRCT) D ^ACHSTX99
Q
;
ADD5B ; Add Patient Name & Ins info to 5B record.
S ACHSPATN=$J(" ",16),ACHSCOMM=$J(" ",7)
I +PATNUM<1 G ADD5B2
ADD5B1 ;
S:$D(^DPT(DFN)) ACHSPATN=$E($P(^DPT(DFN,0),U,1)_$J(" ",16),1,16)
S ACHSCOMM=$J(" ",7)
I $P(^AUPNPAT(DFN,11),U,18)]"",$D(^AUTTCOM("B",$P(^(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 ;
KILL 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)
KILL ACHSZZI
S RET=0
Q
;
SETCN ;
;set the contract number into ACHSCN. this is complicated.
;If there is a contract pointer on this PO, then
; get the contract info from the vendor file and
; extract the numbers.
; If the numbers are found on a certain list, then
; use that number for ACHSCN
; else
; concatenate those numbers onto the ASUFAC, and use that
; endif
;else
; if there is an agreement number on this PO, then
; get THAT info from the vendor file. Concatenate
; it onto the ASUFAC, and use that for ACHSCN
;else
; use OM for ACHSCN
;endif
;fill ACHSCN with blanks to a length of 10
;
;
S ACHSCN=""
I +CNTRPTR,$G(^AUTTVNDR(VNDPTR,"CN",CNTRPTR,0))'="" D Q
. S ACHSCN=$P(^AUTTVNDR(VNDPTR,"CN",CNTRPTR,0),U,1),Z=""
. F ACHSI=1:1:$L(ACHSCN) I $E(ACHSCN,ACHSI)?1N S Z=Z_$E(ACHSCN,ACHSI)
. I $F("235^239^241^242^243^244^245^246^247^248^249^285",$E(Z,1,3)) S ACHSCN=Z Q
. S ACHSCN=ACHSARCO_Z
. Q
;
I +VNAGPTR,$G(^AUTTVNDR(VNDPTR,18,VNAGPTR,0)) D Q
. S Y=^AUTTVNDR(VNDPTR,18,VNAGPTR,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)
. Q
;
S ACHSCN="OM"
Q
;
ACHSTX55 ; IHS/ADC/GTH - EXPORT DATA (6/9) - RECORD 5(DOCUMENT FOR AO/FI) ;
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
+2 ;
+3 ;
+4 ;we can be 638, or have parm 2,9 set, but not both
+5 IF ACHSF638="Y"
IF (ACHSF209)
SET RET=2
QUIT
+6 IF ACHSTY="P"
SET RET=3
QUIT
+7 IF 'ACHSF211
SET RET=4
QUIT
+8 ;
+9 SET ACHSFAC=ACHSAFAC
SET ACHSREFT=" "
+10 ;
+11 IF $DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,3))
SET ACHSREFT=$PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,3),U,10)
+12 SET ACHSREFT=$EXTRACT(" "_ACHSREFT_" ",1,2)
SET (ACHSEDOS,ACHSFRDT,ACHSTODT)=$JUSTIFY(" ",6)
+13 SET (ACHSEDOS("5C"),ACHSFRDT("5C"),ACHSTODT("5C"))=$JUSTIFY(" ",8)
+14 IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,3))
GOTO C3
+15 SET X=^ACHSF(DUZ(2),"D",ACHSDIEN,3)
+16 ;
+17 IF +$PIECE(X,U,9)>0
SET ACHSEDOS=$EXTRACT($PIECE(X,U,9),2,7)
SET ACHSEDOS("5C")=17000000+$PIECE(X,U,9)
+18 IF +$PIECE(X,U,1)>0
SET ACHSFRDT=$EXTRACT($PIECE(X,U,1),2,7)
SET ACHSFRDT("5C")=17000000+$PIECE(X,U,1)
+19 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 ACHSBIND=$SELECT(BLNKT=1:"Y",BLNKT=0:"N",BLNKT:" ")
+2 ;
+3 IF +CHART>0
SET ACHSHRN=CHART
GOTO C5
+4 ;
+5 SET X=$PIECE(ACHSTRAN,U,3)
+6 IF +X<1
SET ACHSHRN=""
GOTO C5
+7 ;
+8 SET ACHSHRN=$$HRN^ACHS(X,DUZ(2))
+9 ;
C5 ;
+1 SET ACHSHRN=$EXTRACT(ACHSHRN+1000000,2,7)
+2 ;
+3 DO SETCN
SET ACHSCN=$EXTRACT(ACHSCN_$JUSTIFY("",10),1,10)
+4 ;
C6 ;
+1 SET (X,ACHSTYPE)=$PIECE(ACHSTRAN,U,2)
+2 IF '$LENGTH(X)
SET X=" "
+3 SET ACHSSTS=X_" "
+4 IF ACHSSTS="C "
SET X=$PIECE(ACHSDOCR,U,12)
SET ACHSSTS=$EXTRACT(ACHSSTS)_$SELECT((X=2)!(X=3):"P",X=4:"A",1:" ")
+5 DO IPA^ACHSTX8
+6 SET ACHSIPA=$EXTRACT(ACHSIPA,5,12)
+7 IF ACHSTYPE="C"
SET ACHSIPA="-"_$EXTRACT(ACHSIPA,2,8)
+8 SET ACHSESDA=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,1))
SET ACHSESDA=$EXTRACT(1000+ACHSESDA,2,4)
SET ACHSRCT=ACHSRCT+1
SET ACHSRTYP(5)=ACHSRTYP(5)+1
+9 ;
+10 SET VNDEINSX=VNDEINSF
IF VNDEINSX=""
SET VNDEINSX=" "
+11 ;
+12 SET ^ACHSTXOB(ACHSRCT)="5A"_ACHSDOCN_TYPSER2_ACHSAFAC_ACHSBIND_VNDEIN_VNDEINSX_ACHSHRN_ACHSCN_CAN_OCC_$EXTRACT(ORDDAT,2,7)_ACHSSTS_ACHSIPA_ACHSESDA_VNDFNFC
+13 ;
+14 SET PMFF=^ACHSTXOB(ACHSRCT)
DO ^ACHSTX99
+15 ;
C7 ; Build Patient name & 3rd party info for 5B record.
+1 SET ACHSRCT=ACHSRCT+1
SET ACHSRTYP(5)=ACHSRTYP(5)+1
+2 DO ADD5B
+3 ;
+4 SET ^ACHSTXOB(ACHSRCT)="5B"_ACHSREFT_ACHSEDOS_ACHSFRDT_ACHSTODT_ACHSPATN_ACHS5IN1_ACHS5IN2_TRIBE_ACHSCOMM
+5 ;
+6 SET PMFF=^ACHSTXOB(ACHSRCT)
DO ^ACHSTX99
+7 ;
+8 SET ACHSRCT=ACHSRCT+1
SET ACHSRTYP(5)=ACHSRTYP(5)+1
+9 SET ^ACHSTXOB(ACHSRCT)="5C"_SCC_($PIECE(ACHSDOCR,U,2)+17000000)_ACHSEDOS("5C")_ACHSFRDT("5C")_ACHSTODT("5C")_$JUSTIFY("",42)
+10 ;
+11 SET PMFF=^ACHSTXOB(ACHSRCT)
DO ^ACHSTX99
+12 QUIT
+13 ;
ADD5B ; Add Patient Name & Ins info to 5B record.
+1 SET ACHSPATN=$JUSTIFY(" ",16)
SET ACHSCOMM=$JUSTIFY(" ",7)
+2 IF +PATNUM<1
GOTO ADD5B2
ADD5B1 ;
+1 IF $DATA(^DPT(DFN))
SET ACHSPATN=$EXTRACT($PIECE(^DPT(DFN,0),U,1)_$JUSTIFY(" ",16),1,16)
+2 SET ACHSCOMM=$JUSTIFY(" ",7)
+3 IF $PIECE(^AUPNPAT(DFN,11),U,18)]""
IF $DATA(^AUTTCOM("B",$PIECE(^(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 ;
+4 IF +DFN>0
DO ^ACHSTX3C
+5 ;
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 SET RET=0
+6 QUIT
+7 ;
SETCN ;
+1 ;set the contract number into ACHSCN. this is complicated.
+2 ;If there is a contract pointer on this PO, then
+3 ; get the contract info from the vendor file and
+4 ; extract the numbers.
+5 ; If the numbers are found on a certain list, then
+6 ; use that number for ACHSCN
+7 ; else
+8 ; concatenate those numbers onto the ASUFAC, and use that
+9 ; endif
+10 ;else
+11 ; if there is an agreement number on this PO, then
+12 ; get THAT info from the vendor file. Concatenate
+13 ; it onto the ASUFAC, and use that for ACHSCN
+14 ;else
+15 ; use OM for ACHSCN
+16 ;endif
+17 ;fill ACHSCN with blanks to a length of 10
+18 ;
+19 ;
+20 SET ACHSCN=""
+21 IF +CNTRPTR
IF $GET(^AUTTVNDR(VNDPTR,"CN",CNTRPTR,0))'=""
Begin DoDot:1
+22 SET ACHSCN=$PIECE(^AUTTVNDR(VNDPTR,"CN",CNTRPTR,0),U,1)
SET Z=""
+23 FOR ACHSI=1:1:$LENGTH(ACHSCN)
IF $EXTRACT(ACHSCN,ACHSI)?1N
SET Z=Z_$EXTRACT(ACHSCN,ACHSI)
+24 IF $FIND("235^239^241^242^243^244^245^246^247^248^249^285",$EXTRACT(Z,1,3))
SET ACHSCN=Z
QUIT
+25 SET ACHSCN=ACHSARCO_Z
+26 QUIT
End DoDot:1
QUIT
+27 ;
+28 IF +VNAGPTR
IF $GET(^AUTTVNDR(VNDPTR,18,VNAGPTR,0))
Begin DoDot:1
+29 SET Y=^AUTTVNDR(VNDPTR,18,VNAGPTR,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)
+30 IF Z'="PA"
SET W=W_$EXTRACT(X,1,4)
+31 IF Z="PA"
SET W=W_$EXTRACT(X,2,4)
+32 SET ACHSCN=$EXTRACT(ACHSARCO_W_$JUSTIFY("",10),1,10)
+33 QUIT
End DoDot:1
QUIT
+34 ;
+35 SET ACHSCN="OM"
+36 QUIT
+37 ;
