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

ACHSTX3.m

Go to the documentation of this file. 
  1. ACHSTX3 ; IHS/ITSC/PMF - EXPORT DATA (4/9) - RECORD 3(PATIENT FOR AO/FI) ;
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**13,19**;JUN 11,2001
  1.  ;ACHS*3.1*13 11/27/06 IHS/OIT/FCJ PULL INSURED FR CORRECT FILES
  1.  ;
  1.  I $$PARM^ACHS(2,11)'="Y" G AEND
  1.  W !!?10,"BUILDING ",$$REC^ACHSACO1(3)," : ",!?9
  1.  ;*****************BEGIN LOOP THRU PATIENT RECORD 3
  1.  S ACHSR=0
  1.  S ACHSDB=$S($$GET1^DIQ(9999999.06,DUZ(2),.32)=17121:1,1:" ") ;ACHS*3.1*19 NEW LINE TO IDENT DB
  1. A1 ; ^ACHSTXPT(DFN,<facility_pointer>,HRN)
  1.  S ACHSRR=0,ACHSR=$O(^ACHSTXPT(ACHSR))
  1.  G AEND:'ACHSR,A1:'$D(^AUPNPAT(ACHSR,0)),A1:'$D(^DPT(ACHSR,0))
  1.  I ACHSREEX,$D(ACHS("REXNUM")),$P($G(^AUPNPAT(ACHSR,0)),U,15)=$P($G(^ACHSTXST(DUZ(2),1,ACHS("REXNUM"),0)),U,1) G A2
  1.  ;
  1.  ;if the date of last export is greater than the date of last
  1.  ;registration update, stop.  don't export. pmf  11/22/00
  1.  ;
  1.  ;there are TWO 'date of last registration update' fields in ^AUPNPAT 
  1.  ;we want to check against the LATEST one, so figure out which one 
  1.  ;it is 
  1.  S ACHSPND1=$P(^AUPNPAT(ACHSR,0),U,3),ACHSPND2=$P(^AUPNPAT(ACHSR,0),U,16)
  1.  I ACHSPND2>ACHSPND1 S ACHSPND1=ACHSPND2
  1.  I $P(^AUPNPAT(ACHSR,0),U,15)>ACHSPND1 G A1
  1.  ;
  1. A2 ;
  1.  S ACHSHRN=0,ACHSRR=$O(^ACHSTXPT(ACHSR,ACHSRR))
  1.  G A1:'ACHSRR,A1:'$D(^ACHSTXPT(ACHSR,ACHSRR))
  1.  S ACHSFAC=$E(ACHSAFAC_$J("",6),1,6)
  1. A3 ;
  1.  S ACHSHRN=$O(^ACHSTXPT(ACHSR,ACHSRR,ACHSHRN))
  1.  G A2:'ACHSHRN
  1.  S ACHSDEST=$P($G(^ACHSTXPT(ACHSR,ACHSRR,ACHSHRN)),U),ACHSDOB="0000000"
  1.  I +$P($G(^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($G(^DPT(ACHSR,0)),U,2)_" "),DFN=ACHSR
  1.  D TRIB^ACHSTX8
  1. A4 ;
  1.  S ACHSNAME=$E($P($G(^DPT(ACHSR,0)),U)_$J("",30),1,30),ACHSCOV="N"
  1.  I $D(^AUPNMCR(ACHSR,0))!$D(^AUPNMRE(ACHSR,0))!$D(^AUPNPRVT(ACHSR,0))!$D(^AUPNMCD("AB",ACHSR)) S ACHSCOV="Y"
  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($G(^AUTTCOM(ACHSCOMM,0)),U,8)_$J("",7),1,7),1:"")
  1. A5 ;
  1.  S ACHSSSN=$P($G(^DPT(ACHSR,0)),U,9)
  1.  I $L(ACHSSSN)'=9 S ACHSSSN=$J("",9)
  1.  S ACHSUPDT=$E($P($G(^AUPNPAT(ACHSR,0)),U,16),2,7)
  1.  ;I '$L(ACHSUPDT) S ACHSUPDT="000000"   ;ACHS*3.1*19
  1.  I $L(ACHSUPDT)'=6 S ACHSUPDT="000000"
  1.  S ACHSRCT=ACHSRCT+1,ACHSRTYP(3)=ACHSRTYP(3)+1
  1.  ;ACHS*3.1*19 CHANGED NXT LINE TO SEND THE DATABASE ID INSTEAD OF THE DOC DEST
  1.  ;S ^ACHSDATA(ACHSRCT)="3A"_ACHSFAC_$E(ACHSHRN+1000000,2,7)_ACHSDOB_ACHSSEX_ACHSTRIB_ACHSNAME_ACHSCOV_ACHSCOMM_ACHSSSN_ACHSUPDT_$E($$SSV(ACHSR)_" ",1)_ACHSDEST
  1.  S ^ACHSDATA(ACHSRCT)="3A"_ACHSFAC_$E(ACHSHRN+1000000,2,7)_ACHSDOB_ACHSSEX_ACHSTRIB_ACHSNAME_ACHSCOV_ACHSCOMM_ACHSSSN_ACHSUPDT_$E($$SSV(ACHSR)_" ",1)_ACHSDB
  1.  ;
  1.  S ACHSRCT=ACHSRCT+1,ACHSRTYP(3)=ACHSRTYP(3)+1
  1.  I '$D(^DPT(ACHSR,.11)) S ^ACHSDATA(ACHSRCT)="3B"_$J("",78) G A7
  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 ^ACHSDATA(ACHSRCT)="3B"_ACHSADDR_ACHSCITY_ACHSST_ACHSZIP_ACHSINSR_ACHSDEST,$P(^AUPNPAT(ACHSR,0),U,15)=DT
  1.  ;D ^ACHSTX3C  do this AFTER tag A7  pmf  12/15/00
  1. A7 ;
  1.  D ^ACHSTX3C
  1.  I ACHSRTYP(3)#10=0 W $J(ACHSRTYP(3),8)
  1.  G A3
  1.  ;
  1. AEND ;
  1.  S ACHSROUT=ACHSRCT
  1.  K ACHSAPN,ACHSINSR,ACHSCITY,ACHSCOMM,ACHSCN,ACHSCOV,ACHSEIN,ACHSFAC,ACHSFED,X1
  1.  K ACHSFONE,ACHSHRN,ACHSUPDT,ACHSNAME,ACHS1099,ACHSDOB,ACHSPTYP,ACHSSEX,ACHSST,ACHSADDR,ACHSTRIB,ACHSSSN,ACHSDAP,ACHSZIP
  1.  S ACHSROUT=ACHSRCT
  1.  G ^ACHSTX4
  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)       ;SSN VERIFICATION STATUS
  1.                                       ;FROM PATIENT FILE, PTR TO SSN
  1.  I 'X Q ""
  1.  Q $P($G(^AUTTSSN(X,0)),U)          ;CODE FIELD IN STATUS FILE  
  1.  ;