ACHSTX77 ;IHS/ADC/GTH - EXPORT DATA (8/9) - RECORD 7(638 STATISTICAL DATA FOR NPIRS) ; [ 12/06/2002 10:36 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5**;JUN 11, 2001
;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Remove old references to v 3 p9.
I 'ACHSF638,('ACHSF209) Q
I ACHSTY'="P" S RET=3 Q
I DESTN'="I" S RET=15 Q
I +DFN=0 S RET=19 Q
;
I $G(^DPT(DFN,0))="" S RET=21 Q
;
S ACHSSEX=$S($P(^DPT(DFN,0),U,2)="F":2,1:1),%=$P(^(0),U,3),ACHSDOB=17000000+%
S ACHSX=$P(ACHSDOCR,U,14)
D FYCVT^ACHSFU
;
S ACHSAUTH=$E(ACHSY,3,4)_$E(+$P(ACHSDOCR,U)+100000,2,6)
HRN ;
S ACHSHRN=$$HRN^ACHS(DFN,DUZ(2)),ACHSHRN=$E(1000000+ACHSHRN,2,7)
SSN ;
S ACHSSSN=$E($$SSN^AUPNPAT(DFN)_$J("",9),1,9)
;
COMM ;
S ACHSCOMM=$J("",7)
I $P(^AUPNPAT(DFN,11),U,18)]"",$D(^AUTTCOM("B",$P(^(11),U,18))) S %=$P(^AUTTCOM($O(^AUTTCOM("B",$P(^AUPNPAT(DFN,11),U,18),0)),0),U,8),ACHSCOMM=$E(%,5,7)_$E(%,3,4)_$E(%,1,2)
PTYP ;
S ACHSPTYP=$J("",2)
I $P(^AUTTVNDR($P(ACHSDOCR,U,8),11),U,3) S ACHSPTYP=$P(^AUTTVTYP($P(^(11),U,3),0),U),ACHSPTYP=$E(ACHSPTYP_" ",1,2)
EIN ;
S ACHSEIN=$E($P(^AUTTVNDR($P(ACHSDOCR,U,8),11),U)_$J("",10),1,10)
IPA ;
S ACHSIPA=$J("",8)
I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")) S ACHSIPA=+$P(^("PA"),U)
S ACHSIPA=$P(ACHSIPA,".")_$E($P(ACHSIPA,".",2)_"00",1,2),ACHSIPA=$E(100000000+ACHSIPA,2,9)
I TYPSER2=57 G 57
;
S ACHSFULP=$S($P(ACHSTRAN,U,5)="P":2,1:1)
;
S ACHSDATA=ACHSAUTH_ACHSHRN_ACHSSSN_ACHSDOB_ACHSSEX_TRIBE_" "_ACHSCOMM_ACHSAFAC_ACHSPTYP_ACHSEIN
D DXPX^ACHSTX7A
G @TYPSER2
;
43 ;
S ACHSADDT=$J("",6)
I $P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,8)),U,2) S %=$P(^(8),U,2),ACHSADDT=17000000+%
I +ACHSADDT<1 Q
S ACHSDIDT=$J("",6)
I $P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,8)),U,3) S %=$P(^(8),U,3),ACHSDIDT=17000000+%
;
S DA(1)=DUZ(2),DA=ACHSDIEN
S ACHSLOS=$E(1000+$$VAL^XBDIQ1(9002080.01,.DA,93),2,4)
;
S ACHSDITY=$S($P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,8)),U,4):$P(^(8),U,4),1:1),ACHSDITY=$S($D(^DIC(42.2,ACHSDITY,9999999)):$P(^(9999999),U),1:1)
;
S DA(1)=DUZ(2),DA=ACHSDIEN
S ACHSRCOI=$$VAL^XBDIQ1(9002080.01,.DA,82)
S:ACHSRCOI["E" ACHSRCOI=$P(ACHSRCOI,"E",2)
S:ACHSRCOI["." ACHSRCOI=$P(ACHSRCOI,".")_$P(ACHSRCOI,".",2)
S ACHSRCOI=$E(ACHSRCOI_$J("",4),1,4)
I +ACHSRCOI<1 S ACHSRCOI=" "
ECFIX ;
KILL Z
F ACHSI=1:1:5 I ACHSDX(ACHSI)["E" S Z(ACHSI)=ACHSDX(ACHSI) F ACHSJ=ACHSI:1 Q:ACHSJ=5 S ACHSDX(ACHSJ)=ACHSDX(ACHSJ+1),ACHSDX(ACHSJ+1)=" "
S W=0,ACHSINJP=" ",W=$O(Z(W))
I W>0 S ACHSRCOI=$E(Z(W),2,5),ACHSINJP="12"
S Z=""
F ACHSI=1:1:5 I +$E(ACHSDX(ACHSI),1,3)>799 S Z="EC"
I Z="EC"&(ACHSRCOI=" ") S ACHSRCOI="9889",ACHSINJP="12"
S ACHSDATA=19_ACHSDATA_ACHSADDT_ACHSDIDT_ACHSLOS_ACHSDITY_ACHSDX(1)_ACHSDX(2)_ACHSDX(3)_ACHSDX(4)_ACHSDX(5)_ACHSPX(1)_" "_ACHSPX(2)_ACHSPX(3)_" "_ACHSRCOI_ACHSINJP_ACHSIPA_ACHSFULP
Q
;
57 ;
S ACHS=$$ADA^ACHSTX7A(DUZ(2),ACHSDIEN)
S ACHSDATA=25_$P(^AUTTLOC(DUZ(2),0),U,10)_$E(ACHSEIN,2,10)_$S(ACHSSEX=1:"M",1:"F")_ACHSDOB_ACHSSSN_$P(ACHS,U)_$P(ACHS,U,2)_$S($P(ACHSTRAN,U,10):17000000+$P(ACHSTRAN,U,10),1:$J("",8))
S ACHSDATA=ACHSDATA_$J("",32)_$$AGE^ACHSTX7A(DFN)_$P(ACHS,U,3)
G A3
;
64 ;
I +ACHSAPC(1)<1 Q
C64 ;
S ACHSHONN=$J("",7)
I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,2)),$P(^(2),U),$D(^ACHSF(DUZ(2),"D",$P(^(2),U),0)) S ACHSX=$P(^(0),U,14),ACHSHONN=$P(^(0),U) D FYCVT^ACHSFU S ACHSHONN=$E(ACHSY,3,4)_ACHSHONN
S ACHSDOS=$J("",8)
I $P(ACHSTRAN,U,10) S %=$P(ACHSTRAN,U,10),ACHSDOS=17000000+%
S ACHSIPA=$E(ACHSIPA,3,8),%=$P(ACHSTRAN,U,9),ACHSVST=$E(100+%,2,3)
S ACHSDATA=20_ACHSDATA_ACHSHONN_ACHSDOS_2_ACHSAPC(1)_$S(ACHSAPC(1)=" ":" ",1:1)_ACHSAPC(2)_$S(ACHSAPC(2)=" ":" ",1:1)_ACHSVST_ACHSIPA_$J("",13)_ACHSFULP_ACHSPX(1)
A3 ;
S ACHSDATA=ACHSDATA_$J("",162-$L(ACHSDATA))
S ACHSRCT=ACHSRCT+1,^ACHSTXPG(ACHSRCT)="7A"_$E(ACHSDATA,1,78),ACHSRTYP(7)=ACHSRTYP(7)+1
S PMFF=^ACHSTXPG(ACHSRCT) D ^ACHSTX99
S ACHSRCT=ACHSRCT+1,^ACHSTXPG(ACHSRCT)="7B"_$E(ACHSDATA,79,156),ACHSRTYP(7)=ACHSRTYP(7)+1
S PMFF=^ACHSTXPG(ACHSRCT) D ^ACHSTX99
;
I TYPSER2=57 S ACHSRCT=ACHSRCT+1,^ACHSTXPG(ACHSRCT)="7C"_$E(ACHSDATA,157,234),ACHSRTYP(7)=ACHSRTYP(7)+1
S PMFF=^ACHSTXPG(ACHSRCT) D ^ACHSTX99
I ACHSRTYP(7)#10=0 W $J(ACHSRTYP(7),8)
S RET=0
Q
;
ACHSTX77 ;IHS/ADC/GTH - EXPORT DATA (8/9) - RECORD 7(638 STATISTICAL DATA FOR NPIRS) ; [ 12/06/2002 10:36 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5**;JUN 11, 2001
+2 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Remove old references to v 3 p9.
+3 IF 'ACHSF638
IF ('ACHSF209)
QUIT
+4 IF ACHSTY'="P"
SET RET=3
QUIT
+5 IF DESTN'="I"
SET RET=15
QUIT
+6 IF +DFN=0
SET RET=19
QUIT
+7 ;
+8 IF $GET(^DPT(DFN,0))=""
SET RET=21
QUIT
+9 ;
+10 SET ACHSSEX=$SELECT($PIECE(^DPT(DFN,0),U,2)="F":2,1:1)
SET %=$PIECE(^(0),U,3)
SET ACHSDOB=17000000+%
+11 SET ACHSX=$PIECE(ACHSDOCR,U,14)
+12 DO FYCVT^ACHSFU
+13 ;
+14 SET ACHSAUTH=$EXTRACT(ACHSY,3,4)_$EXTRACT(+$PIECE(ACHSDOCR,U)+100000,2,6)
HRN ;
+1 SET ACHSHRN=$$HRN^ACHS(DFN,DUZ(2))
SET ACHSHRN=$EXTRACT(1000000+ACHSHRN,2,7)
SSN ;
+1 SET ACHSSSN=$EXTRACT($$SSN^AUPNPAT(DFN)_$JUSTIFY("",9),1,9)
+2 ;
COMM ;
+1 SET ACHSCOMM=$JUSTIFY("",7)
+2 IF $PIECE(^AUPNPAT(DFN,11),U,18)]""
IF $DATA(^AUTTCOM("B",$PIECE(^(11),U,18)))
SET %=$PIECE(^AUTTCOM($ORDER(^AUTTCOM("B",$PIECE(^AUPNPAT(DFN,11),U,18),0)),0),U,8)
SET ACHSCOMM=$EXTRACT(%,5,7)_$EXTRACT(%,3,4)_$EXTRACT(%,1,2)
PTYP ;
+1 SET ACHSPTYP=$JUSTIFY("",2)
+2 IF $PIECE(^AUTTVNDR($PIECE(ACHSDOCR,U,8),11),U,3)
SET ACHSPTYP=$PIECE(^AUTTVTYP($PIECE(^(11),U,3),0),U)
SET ACHSPTYP=$EXTRACT(ACHSPTYP_" ",1,2)
EIN ;
+1 SET ACHSEIN=$EXTRACT($PIECE(^AUTTVNDR($PIECE(ACHSDOCR,U,8),11),U)_$JUSTIFY("",10),1,10)
IPA ;
+1 SET ACHSIPA=$JUSTIFY("",8)
+2 IF $DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"))
SET ACHSIPA=+$PIECE(^("PA"),U)
+3 SET ACHSIPA=$PIECE(ACHSIPA,".")_$EXTRACT($PIECE(ACHSIPA,".",2)_"00",1,2)
SET ACHSIPA=$EXTRACT(100000000+ACHSIPA,2,9)
+4 IF TYPSER2=57
GOTO 57
+5 ;
+6 SET ACHSFULP=$SELECT($PIECE(ACHSTRAN,U,5)="P":2,1:1)
+7 ;
+8 SET ACHSDATA=ACHSAUTH_ACHSHRN_ACHSSSN_ACHSDOB_ACHSSEX_TRIBE_" "_ACHSCOMM_ACHSAFAC_ACHSPTYP_ACHSEIN
+9 DO DXPX^ACHSTX7A
+10 GOTO @TYPSER2
+11 ;
43 ;
+1 SET ACHSADDT=$JUSTIFY("",6)
+2 IF $PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,8)),U,2)
SET %=$PIECE(^(8),U,2)
SET ACHSADDT=17000000+%
+3 IF +ACHSADDT<1
QUIT
+4 SET ACHSDIDT=$JUSTIFY("",6)
+5 IF $PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,8)),U,3)
SET %=$PIECE(^(8),U,3)
SET ACHSDIDT=17000000+%
+6 ;
+7 SET DA(1)=DUZ(2)
SET DA=ACHSDIEN
+8 SET ACHSLOS=$EXTRACT(1000+$$VAL^XBDIQ1(9002080.01,.DA,93),2,4)
+9 ;
+10 SET ACHSDITY=$SELECT($PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,8)),U,4):$PIECE(^(8),U,4),1:1)
SET ACHSDITY=$SELECT($DATA(^DIC(42.2,ACHSDITY,9999999)):$PIECE(^(9999999),U),1:1)
+11 ;
+12 SET DA(1)=DUZ(2)
SET DA=ACHSDIEN
+13 SET ACHSRCOI=$$VAL^XBDIQ1(9002080.01,.DA,82)
+14 IF ACHSRCOI["E"
SET ACHSRCOI=$PIECE(ACHSRCOI,"E",2)
+15 IF ACHSRCOI["."
SET ACHSRCOI=$PIECE(ACHSRCOI,".")_$PIECE(ACHSRCOI,".",2)
+16 SET ACHSRCOI=$EXTRACT(ACHSRCOI_$JUSTIFY("",4),1,4)
+17 IF +ACHSRCOI<1
SET ACHSRCOI=" "
ECFIX ;
+1 KILL Z
+2 FOR ACHSI=1:1:5
IF ACHSDX(ACHSI)["E"
SET Z(ACHSI)=ACHSDX(ACHSI)
FOR ACHSJ=ACHSI:1
IF ACHSJ=5
QUIT
SET ACHSDX(ACHSJ)=ACHSDX(ACHSJ+1)
SET ACHSDX(ACHSJ+1)=" "
+3 SET W=0
SET ACHSINJP=" "
SET W=$ORDER(Z(W))
+4 IF W>0
SET ACHSRCOI=$EXTRACT(Z(W),2,5)
SET ACHSINJP="12"
+5 SET Z=""
+6 FOR ACHSI=1:1:5
IF +$EXTRACT(ACHSDX(ACHSI),1,3)>799
SET Z="EC"
+7 IF Z="EC"&(ACHSRCOI=" ")
SET ACHSRCOI="9889"
SET ACHSINJP="12"
+8 SET ACHSDATA=19_ACHSDATA_ACHSADDT_ACHSDIDT_ACHSLOS_ACHSDITY_ACHSDX(1)_ACHSDX(2)_ACHSDX(3)_ACHSDX(4)_ACHSDX(5)_ACHSPX(1)_" "_ACHSPX(2)_ACHSPX(3)_" "_ACHSRCOI_ACHSINJP_ACHSIPA_ACHSFULP
+9 QUIT
+10 ;
57 ;
+1 SET ACHS=$$ADA^ACHSTX7A(DUZ(2),ACHSDIEN)
+2 SET ACHSDATA=25_$PIECE(^AUTTLOC(DUZ(2),0),U,10)_$EXTRACT(ACHSEIN,2,10)_$SELECT(ACHSSEX=1:"M",1:"F")_ACHSDOB_ACHSSSN_$PIECE(ACHS,U)_$PIECE(ACHS,U,2)_$SELECT($PIECE(ACHSTRAN,U,10):17000000+$PIECE(ACHSTRAN,U,10),1:$JUSTIFY("",8))
+3 SET ACHSDATA=ACHSDATA_$JUSTIFY("",32)_$$AGE^ACHSTX7A(DFN)_$PIECE(ACHS,U,3)
+4 GOTO A3
+5 ;
64 ;
+1 IF +ACHSAPC(1)<1
QUIT
C64 ;
+1 SET ACHSHONN=$JUSTIFY("",7)
+2 IF $DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,2))
IF $PIECE(^(2),U)
IF $DATA(^ACHSF(DUZ(2),"D",$PIECE(^(2),U),0))
SET ACHSX=$PIECE(^(0),U,14)
SET ACHSHONN=$PIECE(^(0),U)
DO FYCVT^ACHSFU
SET ACHSHONN=$EXTRACT(ACHSY,3,4)_ACHSHONN
+3 SET ACHSDOS=$JUSTIFY("",8)
+4 IF $PIECE(ACHSTRAN,U,10)
SET %=$PIECE(ACHSTRAN,U,10)
SET ACHSDOS=17000000+%
+5 SET ACHSIPA=$EXTRACT(ACHSIPA,3,8)
SET %=$PIECE(ACHSTRAN,U,9)
SET ACHSVST=$EXTRACT(100+%,2,3)
+6 SET ACHSDATA=20_ACHSDATA_ACHSHONN_ACHSDOS_2_ACHSAPC(1)_$SELECT(ACHSAPC(1)=" ":" ",1:1)_ACHSAPC(2)_$SELECT(ACHSAPC(2)=" ":" ",1:1)_ACHSVST_ACHSIPA_$JUSTIFY("",13)_ACHSFULP_ACHSPX(1)
A3 ;
+1 SET ACHSDATA=ACHSDATA_$JUSTIFY("",162-$LENGTH(ACHSDATA))
+2 SET ACHSRCT=ACHSRCT+1
SET ^ACHSTXPG(ACHSRCT)="7A"_$EXTRACT(ACHSDATA,1,78)
SET ACHSRTYP(7)=ACHSRTYP(7)+1
+3 SET PMFF=^ACHSTXPG(ACHSRCT)
DO ^ACHSTX99
+4 SET ACHSRCT=ACHSRCT+1
SET ^ACHSTXPG(ACHSRCT)="7B"_$EXTRACT(ACHSDATA,79,156)
SET ACHSRTYP(7)=ACHSRTYP(7)+1
+5 SET PMFF=^ACHSTXPG(ACHSRCT)
DO ^ACHSTX99
+6 ;
+7 IF TYPSER2=57
SET ACHSRCT=ACHSRCT+1
SET ^ACHSTXPG(ACHSRCT)="7C"_$EXTRACT(ACHSDATA,157,234)
SET ACHSRTYP(7)=ACHSRTYP(7)+1
+8 SET PMFF=^ACHSTXPG(ACHSRCT)
DO ^ACHSTX99
+9 IF ACHSRTYP(7)#10=0
WRITE $JUSTIFY(ACHSRTYP(7),8)
+10 SET RET=0
+11 QUIT
+12 ;
