ACHSTX33 ; IHS/ADC/GTH - EXPORT DATA (4/9) - RECORD 3(PATIENT FOR AO/FI) ;
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**13**;JUN 11,2001
;ACHS*3.1*13 11/27/06 IHS/OIT/FCJ PULL INSURED FR CORRECT FILES
;
;To get a type 3 record:
; NOT be both 638 AND parm209=true. either is ok, neither
; is ok.
; I, C, and S types only. Not P, ZA, IP, or others.
; Note: ZA and IP are already
; filtered out by now
; parm 2,11 = y
; must have patient facility, chart num and patient num
; which are stored as pieces 20, 21, and 22 of ACHSDOCR
;
; the patient record must have updated since the last time
; we transmitted it ^AUPNPAT
;
;
;
I ACHSF638="Y",ACHSF209 S RET=2 Q
I ACHSTY="P" S RET=3 Q
I 'ACHSF211 S RET=4 Q
I '$P(ACHSDOCR,U,20) S RET=5 Q
I '$P(ACHSDOCR,U,21) S RET=6 Q
I '$P(ACHSDOCR,U,22) S RET=7 Q
;
S ACHSPAT=$P(ACHSDOCR,U,22)
I '$D(AUPNPAT(ACHSPAT,0)) S RET=8 Q
;
I $P(^AUPNPAT(ACHSR,0),U,15)>$P(^AUPNPAT(ACHSR,0),U,16) S RET=9 Q
;
;
;!!!!! 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
;
;!!!!!!
S ACHSFAC=$E(ACHSAFAC_$J("",6),1,6)
;
S ACHSDOB="0000000"
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)
S ACHSSEX=$E($P(^DPT(ACHSR,0),U,2)_" ")
;
S ACHSNAME=$E($P(^DPT(ACHSR,0),U)_$J("",30),1,30)
;
;do they have other coverage? default no, then look for it.
S 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(^AUTTCOM(ACHSCOMM,0),U,8)_$J("",7),1,7),1:"")
;
;
A5 ;
S ACHSSSN=$P(^DPT(ACHSR,0),U,9)
I $L(ACHSSSN)'=9 S ACHSSSN=$J("",9)
;
;get the SSN verification pointer. if not there, make sure it's null.
;if it IS there, change it to whats in ^AUTTSSN.
S SSV=$P($G(^AUPNPAT(X,0)),U,23) S:'SSV SSV="" I SSV S SSV=$P($G(^AUTTSSN(X,0)),U,1)
;
S ACHSUPDT=$E($P(^AUPNPAT(ACHSR,0),U,16),2,7)
I '$L(ACHSUPDT) S ACHSUPDT="000000"
;
S ACHSRCT=ACHSRCT+1,ACHSRTYP(3)=ACHSRTYP(3)+1
;
S ^ACHSTXPT(ACHSRCT)="3A"_ACHSFAC_$E(ACHSHRN+1000000,2,7)_ACHSDOB_ACHSSEX_TRIBE_ACHSNAME_ACHSCOV_ACHSCOMM_ACHSSSN_ACHSUPDT_$E($$SSV(ACHSR)_" ",1)_ACHSDEST
;
S PMFF=^ACHSTXPT(ACHSRCT) D ^ACHSTX99
;
S ACHSRCT=ACHSRCT+1,ACHSRTYP(3)=ACHSRTYP(3)+1
I '$D(^DPT(ACHSR,.11)) S ^ACHSTXPT(ACHSRCT)="3B"_$J("",78) S PMFF=^ACHSTXPT(ACHSRCT) D ^ACHSTX99 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 ^ACHSTXPT(ACHSRCT)="3B"_ACHSADDR_ACHSCITY_ACHSST_ACHSZIP_ACHSINSR_ACHSDEST,$P(^AUPNPAT(ACHSR,0),U,15)=DT
S PMFF=^ACHSTXPT(ACHSRCT) D ^ACHSTX99
;
A7 ;
D ^ACHSTX3C
;
S RET=0
Q
;
CHKPAT ;
;check the ^AUPNPAT file
I $P(^AUPNPAT(ACHSR,0),U,15)>$P(^AUPNPAT(ACHSR,0),U,16) S RET=9 Q
;!!!!! 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
Q
;
SSV(X) ;EP - Given the pt's DFN, return the SSN verification status code.
S X=$P($G(^AUPNPAT(X,0)),U,23)
I 'X Q ""
Q $P($G(^AUTTSSN(X,0)),U,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
+2 ;ACHS*3.1*13 11/27/06 IHS/OIT/FCJ PULL INSURED FR CORRECT FILES
+3 ;
+4 ;To get a type 3 record:
+5 ; NOT be both 638 AND parm209=true. either is ok, neither
+6 ; is ok.
+7 ; I, C, and S types only. Not P, ZA, IP, or others.
+8 ; Note: ZA and IP are already
+9 ; filtered out by now
+10 ; parm 2,11 = y
+11 ; must have patient facility, chart num and patient num
+12 ; which are stored as pieces 20, 21, and 22 of ACHSDOCR
+13 ;
+14 ; the patient record must have updated since the last time
+15 ; we transmitted it ^AUPNPAT
+16 ;
+17 ;
+18 ;
+19 IF ACHSF638="Y"
IF ACHSF209
SET RET=2
QUIT
+20 IF ACHSTY="P"
SET RET=3
QUIT
+21 IF 'ACHSF211
SET RET=4
QUIT
+22 IF '$PIECE(ACHSDOCR,U,20)
SET RET=5
QUIT
+23 IF '$PIECE(ACHSDOCR,U,21)
SET RET=6
QUIT
+24 IF '$PIECE(ACHSDOCR,U,22)
SET RET=7
QUIT
+25 ;
+26 SET ACHSPAT=$PIECE(ACHSDOCR,U,22)
+27 IF '$DATA(AUPNPAT(ACHSPAT,0))
SET RET=8
QUIT
+28 ;
+29 IF $PIECE(^AUPNPAT(ACHSR,0),U,15)>$PIECE(^AUPNPAT(ACHSR,0),U,16)
SET RET=9
QUIT
+30 ;
+31 ;
+32 ;!!!!! 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
+33 ;
+34 ;!!!!!!
+35 SET ACHSFAC=$EXTRACT(ACHSAFAC_$JUSTIFY("",6),1,6)
+36 ;
+37 SET ACHSDOB="0000000"
+38 IF +$PIECE(^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)
+39 SET ACHSSEX=$EXTRACT($PIECE(^DPT(ACHSR,0),U,2)_" ")
+40 ;
+41 SET ACHSNAME=$EXTRACT($PIECE(^DPT(ACHSR,0),U)_$JUSTIFY("",30),1,30)
+42 ;
+43 ;do they have other coverage? default no, then look for it.
+44 SET ACHSCOV="N"
IF $DATA(^AUPNMCR(ACHSR,0))!$DATA(^AUPNMRE(ACHSR,0))!$DATA(^AUPNPRVT(ACHSR,0))!$DATA(^AUPNMCD("AB",ACHSR))
SET ACHSCOV="Y"
+45 ;
+46 ;
+47 FOR ACHSCOMM=0:0
IF '$ORDER(^AUPNPAT(ACHSR,51,ACHSCOMM))
QUIT
SET ACHSCOMM=$ORDER(^(ACHSCOMM))
+48 IF 'ACHSCOMM
SET ACHSCOMM=$JUSTIFY("",7)
GOTO A5
+49 SET ACHSCOMM=$SELECT($DATA(^AUPNPAT(ACHSR,51,ACHSCOMM,0)):$PIECE(^(0),U,3),1:0)
+50 IF 'ACHSCOMM
SET ACHSCOMM=$JUSTIFY("",7)
GOTO A5
+51 SET ACHSCOMM=$SELECT($DATA(^AUTTCOM(ACHSCOMM,0)):$EXTRACT($PIECE(^AUTTCOM(ACHSCOMM,0),U,8)_$JUSTIFY("",7),1,7),1:"")
+52 ;
+53 ;
A5 ;
+1 SET ACHSSSN=$PIECE(^DPT(ACHSR,0),U,9)
+2 IF $LENGTH(ACHSSSN)'=9
SET ACHSSSN=$JUSTIFY("",9)
+3 ;
+4 ;get the SSN verification pointer. if not there, make sure it's null.
+5 ;if it IS there, change it to whats in ^AUTTSSN.
+6 SET SSV=$PIECE($GET(^AUPNPAT(X,0)),U,23)
IF 'SSV
SET SSV=""
IF SSV
SET SSV=$PIECE($GET(^AUTTSSN(X,0)),U,1)
+7 ;
+8 SET ACHSUPDT=$EXTRACT($PIECE(^AUPNPAT(ACHSR,0),U,16),2,7)
+9 IF '$LENGTH(ACHSUPDT)
SET ACHSUPDT="000000"
+10 ;
+11 SET ACHSRCT=ACHSRCT+1
SET ACHSRTYP(3)=ACHSRTYP(3)+1
+12 ;
+13 SET ^ACHSTXPT(ACHSRCT)="3A"_ACHSFAC_$EXTRACT(ACHSHRN+1000000,2,7)_ACHSDOB_ACHSSEX_TRIBE_ACHSNAME_ACHSCOV_ACHSCOMM_ACHSSSN_ACHSUPDT_$EXTRACT($$SSV(ACHSR)_" ",1)_ACHSDEST
+14 ;
+15 SET PMFF=^ACHSTXPT(ACHSRCT)
DO ^ACHSTX99
+16 ;
+17 SET ACHSRCT=ACHSRCT+1
SET ACHSRTYP(3)=ACHSRTYP(3)+1
+18 IF '$DATA(^DPT(ACHSR,.11))
SET ^ACHSTXPT(ACHSRCT)="3B"_$JUSTIFY("",78)
SET PMFF=^ACHSTXPT(ACHSRCT)
DO ^ACHSTX99
GOTO A7
+19 ;
+20 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)
+21 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 ^ACHSTXPT(ACHSRCT)="3B"_ACHSADDR_ACHSCITY_ACHSST_ACHSZIP_ACHSINSR_ACHSDEST
SET $PIECE(^AUPNPAT(ACHSR,0),U,15)=DT
+2 SET PMFF=^ACHSTXPT(ACHSRCT)
DO ^ACHSTX99
+3 ;
A7 ;
+1 DO ^ACHSTX3C
+2 ;
+3 SET RET=0
+4 QUIT
+5 ;
CHKPAT ;
+1 ;check the ^AUPNPAT file
+2 IF $PIECE(^AUPNPAT(ACHSR,0),U,15)>$PIECE(^AUPNPAT(ACHSR,0),U,16)
SET RET=9
QUIT
+3 ;!!!!! 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
+4 QUIT
+5 ;
SSV(X) ;EP - Given the pt's DFN, return the SSN verification status code.
+1 SET X=$PIECE($GET(^AUPNPAT(X,0)),U,23)
+2 IF 'X
QUIT ""
+3 QUIT $PIECE($GET(^AUTTSSN(X,0)),U,1)
+4 ;
