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

ACHSTX33.m

Go to the documentation of this file. 
  1. ACHSTX33 ; IHS/ADC/GTH - EXPORT DATA (4/9) - RECORD 3(PATIENT FOR AO/FI) ;
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**13**;JUN 11,2001
  1.  ;ACHS*3.1*13 11/27/06 IHS/OIT/FCJ PULL INSURED FR CORRECT FILES
  1.  ;
  1.  ;To get a type 3 record:
  1.  ;       NOT be both 638 AND parm209=true. either is ok, neither
  1.  ;                                         is ok.
  1.  ;       I, C, and S types only.  Not P, ZA, IP, or others.
  1.  ;                                Note:  ZA and IP are already
  1.  ;                                       filtered out by now
  1.  ;       parm 2,11 = y
  1.  ;       must have patient facility, chart num and patient num
  1.  ;       which are stored as pieces 20, 21, and 22 of ACHSDOCR
  1.  ;
  1.  ;       the patient record must have updated since the last time
  1.  ;       we transmitted it  ^AUPNPAT
  1.  ;
  1.  ;
  1.  ;
  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.  I '$P(ACHSDOCR,U,20) S RET=5 Q
  1.  I '$P(ACHSDOCR,U,21) S RET=6 Q
  1.  I '$P(ACHSDOCR,U,22) S RET=7 Q
  1.  ;
  1.  S ACHSPAT=$P(ACHSDOCR,U,22)
  1.  I '$D(AUPNPAT(ACHSPAT,0)) S RET=8 Q
  1.  ;
  1.  I $P(^AUPNPAT(ACHSR,0),U,15)>$P(^AUPNPAT(ACHSR,0),U,16) S RET=9 Q
  1.  ;
  1.  ;
  1.  ;!!!!! WHAT if reexporting??  I $D(ACHSREEX),$D(ACHS("REXNUM")),$P(^AUPNPAT(ACHSR,0),U,15)=$P(^ACHSTXST(DUZ(2),1,ACHS("REXNUM"),0),U,1) G A2
  1.  ;
  1.  ;!!!!!!
  1.  S ACHSFAC=$E(ACHSAFAC_$J("",6),1,6)
  1.  ;
  1.  S ACHSDOB="0000000"
  1.  I +$P(^DPT(ACHSR,0),U,3) S ACHSDOB=$E($P(^(0),U,3),1,3)+1700,ACHSDOB=$E(ACHSDOB,2)_$E($P(^(0),U,3),2,7)
  1.  S ACHSSEX=$E($P(^DPT(ACHSR,0),U,2)_" ")
  1.  ;
  1.  S ACHSNAME=$E($P(^DPT(ACHSR,0),U)_$J("",30),1,30)
  1.  ;
  1.  ;do they have other coverage?  default no, then look for it.
  1.  S ACHSCOV="N" I $D(^AUPNMCR(ACHSR,0))!$D(^AUPNMRE(ACHSR,0))!$D(^AUPNPRVT(ACHSR,0))!$D(^AUPNMCD("AB",ACHSR)) S ACHSCOV="Y"
  1.  ;
  1.  ;
  1.  F ACHSCOMM=0:0 Q:'$O(^AUPNPAT(ACHSR,51,ACHSCOMM))  S ACHSCOMM=$O(^(ACHSCOMM))
  1.  I 'ACHSCOMM S ACHSCOMM=$J("",7) G A5
  1.  S ACHSCOMM=$S($D(^AUPNPAT(ACHSR,51,ACHSCOMM,0)):$P(^(0),U,3),1:0)
  1.  I 'ACHSCOMM S ACHSCOMM=$J("",7) G A5
  1.  S ACHSCOMM=$S($D(^AUTTCOM(ACHSCOMM,0)):$E($P(^AUTTCOM(ACHSCOMM,0),U,8)_$J("",7),1,7),1:"")
  1.  ;
  1.  ;
  1. A5 ;
  1.  S ACHSSSN=$P(^DPT(ACHSR,0),U,9)
  1.  I $L(ACHSSSN)'=9 S ACHSSSN=$J("",9)
  1.  ;
  1.  ;get the SSN verification pointer.  if not there, make sure it's null.
  1.  ;if it IS there, change it to whats in ^AUTTSSN.
  1.  S SSV=$P($G(^AUPNPAT(X,0)),U,23) S:'SSV SSV=""  I SSV S SSV=$P($G(^AUTTSSN(X,0)),U,1)
  1.  ;
  1.  S ACHSUPDT=$E($P(^AUPNPAT(ACHSR,0),U,16),2,7)
  1.  I '$L(ACHSUPDT) S ACHSUPDT="000000"
  1.  ;
  1.  S ACHSRCT=ACHSRCT+1,ACHSRTYP(3)=ACHSRTYP(3)+1
  1.  ;
  1.  S ^ACHSTXPT(ACHSRCT)="3A"_ACHSFAC_$E(ACHSHRN+1000000,2,7)_ACHSDOB_ACHSSEX_TRIBE_ACHSNAME_ACHSCOV_ACHSCOMM_ACHSSSN_ACHSUPDT_$E($$SSV(ACHSR)_" ",1)_ACHSDEST
  1.  ;
  1.  S PMFF=^ACHSTXPT(ACHSRCT) D ^ACHSTX99
  1.  ;
  1.  S ACHSRCT=ACHSRCT+1,ACHSRTYP(3)=ACHSRTYP(3)+1
  1.  I '$D(^DPT(ACHSR,.11)) S ^ACHSTXPT(ACHSRCT)="3B"_$J("",78) S PMFF=^ACHSTXPT(ACHSRCT) D ^ACHSTX99 G A7
  1.  ;
  1.  S ACHSADDR=$E($P(^DPT(ACHSR,.11),U)_$J("",30),1,30),ACHSCITY=$E($P(^DPT(ACHSR,.11),U,4)_$J("",20),1,20),X=$P(^DPT(ACHSR,.11),U,5),ACHSST=$S('X:"  ",1:$P(^DIC(5,X,0),U,2)),ACHSZIP=$E($P(^DPT(ACHSR,.11),U,6)_$J("",9),1,9),ACHSINSR=$J("",16)
  1.  S X=""
  1. A5A ;
  1.  S X=$O(^AUPNPRVT(ACHSR,11,X))
  1.  G A6:+X=0
  1.  ;ACHS*3.1*13 11/27/06 IHS/OIT/FCJ PULL INSURED FR CORRECT FILES
  1.  ;I $P($G(^AUPNPRVT(ACHSR,11,X,0)),U,4)="" G A5A
  1.  ;S ACHSINSR=$E($P($G(^AUPNPRVT(ACHSR,11,X,0)),U,4)_$J("",16),1,16)
  1.  S X1=$P($G(^AUPNPRVT(ACHSR,11,X,0)),U,8)
  1.  I $P(^AUPNPRVT(ACHSR,0),U)=$P(^AUPN3PPH(X1,0),U,2) G A5A
  1.  S ACHSINSR=$E($P(^AUPN3PPH(X1,0),U)_$J("",16),1,16)
  1.  ;ACHS*3.1*13 11/27/06 IHS/OIT/FCJ END OF CHANGES
  1. A6 ;
  1.  S ^ACHSTXPT(ACHSRCT)="3B"_ACHSADDR_ACHSCITY_ACHSST_ACHSZIP_ACHSINSR_ACHSDEST,$P(^AUPNPAT(ACHSR,0),U,15)=DT
  1.  S PMFF=^ACHSTXPT(ACHSRCT) D ^ACHSTX99
  1.  ;
  1. A7 ;
  1.  D ^ACHSTX3C
  1.  ;
  1.  S RET=0
  1.  Q
  1.  ;
  1. CHKPAT ;
  1.  ;check the ^AUPNPAT file
  1.  I $P(^AUPNPAT(ACHSR,0),U,15)>$P(^AUPNPAT(ACHSR,0),U,16) S RET=9 Q
  1.  ;!!!!! WHAT if reexporting??    I $D(ACHSREEX),$D(ACHS("REXNUM")),$P(^AUPNPAT(ACHSR,0),U,15)=$P(^ACHSTXST(DUZ(2),1,ACHS("REXNUM"),0),U,1) G A2
  1.  Q
  1.  ;
  1. SSV(X) ;EP - Given the pt's DFN, return the SSN verification status code.
  1.  S X=$P($G(^AUPNPAT(X,0)),U,23)
  1.  I 'X Q ""
  1.  Q $P($G(^AUTTSSN(X,0)),U,1)
  1.  ;