Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACHSTX5

ACHSTX5.m

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