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

ACHSTX55.m

Go to the documentation of this file. 
  1. ACHSTX55 ; IHS/ADC/GTH - EXPORT DATA (6/9) - RECORD 5(DOCUMENT FOR AO/FI) ;  
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
  1.  ;
  1.  ;
  1.  ;we can be 638, or have parm 2,9 set, but not both
  1.  I ACHSF638="Y",(ACHSF209) S RET=2 Q
  1.  I ACHSTY="P" S RET=3 Q
  1.  I 'ACHSF211 S RET=4 Q
  1.  ;
  1.  S ACHSFAC=ACHSAFAC,ACHSREFT=" "
  1.  ;
  1.  S:$D(^ACHSF(DUZ(2),"D",ACHSDIEN,3)) ACHSREFT=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,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",ACHSDIEN,3))
  1.  S X=^ACHSF(DUZ(2),"D",ACHSDIEN,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 ACHSBIND=$S(BLNKT=1:"Y",BLNKT=0:"N",BLNKT:" ")
  1.  ;
  1.  I +CHART>0 S ACHSHRN=CHART G C5
  1.  ;
  1.  S X=$P(ACHSTRAN,U,3)
  1.  I +X<1 S ACHSHRN="" G C5
  1.  ;
  1.  S ACHSHRN=$$HRN^ACHS(X,DUZ(2))
  1.  ;
  1. C5 ;
  1.  S ACHSHRN=$E(ACHSHRN+1000000,2,7)
  1.  ;
  1.  D SETCN S ACHSCN=$E(ACHSCN_$J("",10),1,10)
  1.  ;
  1. C6 ;
  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=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,1)),ACHSESDA=$E(1000+ACHSESDA,2,4),ACHSRCT=ACHSRCT+1,ACHSRTYP(5)=ACHSRTYP(5)+1
  1.  ;
  1.  S VNDEINSX=VNDEINSF I VNDEINSX="" S VNDEINSX="  "
  1.  ;
  1.  S ^ACHSTXOB(ACHSRCT)="5A"_ACHSDOCN_TYPSER2_ACHSAFAC_ACHSBIND_VNDEIN_VNDEINSX_ACHSHRN_ACHSCN_CAN_OCC_$E(ORDDAT,2,7)_ACHSSTS_ACHSIPA_ACHSESDA_VNDFNFC
  1.  ;
  1.  S PMFF=^ACHSTXOB(ACHSRCT) D ^ACHSTX99
  1.  ;
  1. C7 ; Build Patient name & 3rd party info for 5B record.
  1.  S ACHSRCT=ACHSRCT+1,ACHSRTYP(5)=ACHSRTYP(5)+1
  1.  D ADD5B
  1.  ;
  1.  S ^ACHSTXOB(ACHSRCT)="5B"_ACHSREFT_ACHSEDOS_ACHSFRDT_ACHSTODT_ACHSPATN_ACHS5IN1_ACHS5IN2_TRIBE_ACHSCOMM
  1.  ;
  1.  S PMFF=^ACHSTXOB(ACHSRCT) D ^ACHSTX99
  1.  ;
  1.  S ACHSRCT=ACHSRCT+1,ACHSRTYP(5)=ACHSRTYP(5)+1
  1.  S ^ACHSTXOB(ACHSRCT)="5C"_SCC_($P(ACHSDOCR,U,2)+17000000)_ACHSEDOS("5C")_ACHSFRDT("5C")_ACHSTODT("5C")_$J("",42)
  1.  ;
  1.  S PMFF=^ACHSTXOB(ACHSRCT) D ^ACHSTX99
  1.  Q
  1.  ;
  1. ADD5B ; Add Patient Name & Ins info to 5B record.
  1.  S ACHSPATN=$J(" ",16),ACHSCOMM=$J(" ",7)
  1.  I +PATNUM<1 G ADD5B2
  1. ADD5B1 ; 
  1.  S:$D(^DPT(DFN)) ACHSPATN=$E($P(^DPT(DFN,0),U,1)_$J(" ",16),1,16)
  1.  S ACHSCOMM=$J(" ",7)
  1.  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)
  1. ADD5B2 ;
  1.  KILL ACHS3C,ACHS5IN1,ACHS5IN2,ACHSX18,ACHSX19
  1.  S ACHSZZI=1,(ACHSX18,ACHSX19,ACHSDEST,ACHS5IN1,ACHS5IN2)="",ACHSR=DFN,ACHS3CFL=0
  1.  ;
  1.  D ^ACHSTX3C:+DFN>0
  1.  ;
  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.  KILL ACHSZZI
  1.  S RET=0
  1.  Q
  1.  ;
  1. SETCN ;
  1.  ;set the contract number into ACHSCN.  this is complicated.
  1.  ;If there is a contract pointer on this PO, then
  1.  ;  get the contract info from the vendor file and
  1.  ;  extract the numbers.
  1.  ;  If the numbers are found on a certain list, then
  1.  ;    use that number for ACHSCN
  1.  ;  else
  1.  ;    concatenate those numbers onto the ASUFAC, and use that
  1.  ;  endif
  1.  ;else
  1.  ;  if there is an agreement number on this PO, then
  1.  ;    get THAT info from the vendor file.  Concatenate
  1.  ;    it onto the ASUFAC, and use that for ACHSCN
  1.  ;else
  1.  ;  use OM for ACHSCN
  1.  ;endif
  1.  ;fill ACHSCN with blanks to a length of 10
  1.  ;
  1.  ;
  1.  S ACHSCN=""
  1.  I +CNTRPTR,$G(^AUTTVNDR(VNDPTR,"CN",CNTRPTR,0))'="" D  Q
  1.  . S ACHSCN=$P(^AUTTVNDR(VNDPTR,"CN",CNTRPTR,0),U,1),Z=""
  1.  . F ACHSI=1:1:$L(ACHSCN) I $E(ACHSCN,ACHSI)?1N S Z=Z_$E(ACHSCN,ACHSI)
  1.  . I $F("235^239^241^242^243^244^245^246^247^248^249^285",$E(Z,1,3)) S ACHSCN=Z Q
  1.  . S ACHSCN=ACHSARCO_Z
  1.  . Q
  1.  ;
  1.  I +VNAGPTR,$G(^AUTTVNDR(VNDPTR,18,VNAGPTR,0)) D  Q
  1.  . 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)
  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)
  1.  . Q
  1.  ;
  1.  S ACHSCN="OM"
  1.  Q
  1.  ;