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