BLRDPT1 ; IHS/DIR/FJE - PATIENT VARIABLES ;
;;5.2;BLR;;NOV 01, 1997
;
;;MAS VERSION 5.0;
1 ;Demographic [DEM]
N W,Z
;
; -- name [1 - NM]
S VAX=^DPT(DFN,0),@VAV@($P(VAS,"^",1))=$P(VAX,"^")
;
; -- ssn [2 - SS]
S Z=$P(VAX,"^",9) S:Z]"" @VAV@($P(VAS,"^",2))=Z_$S(Z]"":"^"_$E(Z,1,3)_"-"_$E(Z,4,5)_"-"_$E(Z,6,10),1:"")
;
; -- date of birth [2 - DB]
S Z=$P(VAX,"^",3),Y=Z I Y]"" X ^DD("DD") S @VAV@($P(VAS,"^",3))=Z_"^"_Y
;
; -- age [4 - AG]
S W=$S('$D(^DPT(DFN,.35)):"",'^(.35):"",1:+^(.35)) S Y=$S('W:DT,1:W) S:Z]"" @VAV@($P(VAS,"^",4))=$E(Y,1,3)-$E(Z,1,3)-($E(Y,4,7)<$E(Z,4,7))
I @VAV@($P(VAS,"^",4))<2 D PAGE ;IHS/ANMC/CLS 10/15/94
;
; -- expired date [6 - EX]
S (Y,Z)=W X:Y]"" ^DD("DD") S:Z]"" @VAV@($P(VAS,"^",6))=Z_"^"_Y
;
; -- sex [5 - SX]
S Z=$P(VAX,"^",2) S:Z]"" @VAV@($P(VAS,"^",5))=Z_"^"_$S(Z="M":"MALE",Z="F":"FEMALE",1:"") K Z
;
; -- remarks [7 - RE]
S @VAV@($P(VAS,"^",7))=$P(VAX,"^",10)
;
; -- race [8 - RA]
S Z=$P(VAX,"^",6),@VAV@($P(VAS,"^",8))=Z_$S($D(^DIC(10,+Z,0)):"^"_$P(^(0),"^"),1:"")
;
; -- religion [9 - RP]
S Z=$P(VAX,"^",8),@VAV@($P(VAS,"^",9))=Z_$S($D(^DIC(13,+Z,0)):"^"_$P(^(0),"^"),1:"")
;
; -- marital status [10 - MS]
S Z=$P(VAX,"^",5),@VAV@($P(VAS,"^",10))=Z_$S($D(^DIC(11,+Z,0)):"^"_$P(^(0),"^"),1:"")
;
; -- IHS health record number [11 - HR]
S Z=$S($P($G(^AUPNPAT(+$G(DFN),41,+$G(DUZ(2)),0)),U,2)'="":$P(^(0),U,2),1:"??"),@VAV@($P(VAS,"^",11))=Z ;IHS/ANMC/CLS 10/15/94
Q
;
PAGE ; -- IHS printable age ;IHS/ANMC/CLS 10/15/94
N X,X1,X2,Y,AUX,D0
S D0=DFN X ^DD(9000001,1102.98,9.3) S X=$P(Y(9000001,1102.98,101),U,3),Y=X,X=Y(9000001,1102.98,1),X=X,X1=X,X2=Y,X="" D:X2 ^%DTC:X1 S AUX=X\365.25,X=$S(AUX>2:AUX_" YRS",X<31:X_" DYS",1:X\30_" MOS") K AUX S D0=Y(9000001,1102.98,80)
S @VAV@($P(VAS,"^",4))=X Q
;
2 ;Other Patient Variables [OPD]
N W,Z
S VAX=^DPT(DFN,0)
;
; -- city of birth [1 - BC]
S @VAV@($P(VAS,"^",1))=$P(VAX,"^",11)
;
; -- state of birth [2 - BS]
S Z=$P(VAX,"^",12),@VAV@($P(VAS,"^",2))=Z_$S($D(^DIC(5,+Z,0)):"^"_$P(^(0),"^",1),1:"")
;
; -- occupation [6 - OC]
S @VAV@($P(VAS,"^",6))=$P(VAX,"^",7)
;
; -- names
S VAX=$S($D(^DPT(DFN,.24)):^(.24),1:"")
S @VAV@($P(VAS,"^",3))=$P(VAX,"^",1) ; father's [3 - FN]
S @VAV@($P(VAS,"^",4))=$P(VAX,"^",2) ; mother's [4 - MN]
S @VAV@($P(VAS,"^",5))=$P(VAX,"^",3) ; mother's maiden [5 - MM]
;
; -- employment status [7 - ES]
S VAX=$S($D(^DPT(DFN,.311)):^(.311),1:""),W="EMPLOYED FULL TIME^EMPLOYED PART TIME^NOT EMPLOYED^SELF EMPLOYED^RETIRED^ACTIVE MILITARY DUTY^UNKNOWN"
S Z=$P(VAX,"^",15),@VAV@($P(VAS,"^",7))=Z_$S(Z:"^"_$P(W,"^",Z),1:"")
Q
;
3 ;Address [ADD]
S VABEG=$S($D(VATEST("ADD",9)):VATEST("ADD",9),1:DT),VAEND=$S($D(VATEST("ADD",10)):VATEST("ADD",10),1:DT)
I $S($D(VAPA("P")):1,'$D(^DPT(DFN,.121)):1,$P(^(.121),"^",9)'="Y":1,'$P(^(.121),"^",7):1,$P(^(.121),"^",7)>VABEG:1,'$P(^(.121),"^",8):0,1:$P(^(.121),"^",8)<VAEND) S VAX=$S($D(^DPT(DFN,.11)):^(.11),1:""),VAX(1)=0
E S VAX=$S($D(^DPT(DFN,.121)):^(.121),1:""),VAX(1)=1
F I=1:1:6 S VAZ=$P(VAX,"^",I),@VAV@($P(VAS,"^",I))=VAZ I I=5,$D(^DIC(5,+VAZ,0)) S VAZ=$P(^(0),"^"),@VAV@($P(VAS,"^",5))=@VAV@($P(VAS,"^",5))_"^"_VAZ
I 'VAX(1) S VAZ=$P(VAX,"^",7) S:$D(^DIC(5,+$P(VAX,"^",5),1,+VAZ,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",7))=VAZ S:$D(^DPT(DFN,.13)) @VAV@($P(VAS,"^",8))=$P(^(.13),"^",1) G Q3
S @VAV@($P(VAS,"^",8))=$P(VAX,"^",10)
F I=7,8 S VAZ=$P(VAX,"^",I),Y=VAZ X:Y]"" ^DD("DD") S @VAV@($P(VAS,"^",I+2))=VAZ_"^"_Y
Q3 K VABEG,VAEND Q
;
4 ;Other Address [OAD]
I $S('$D(VAOA("A")):1,VAOA("A")<1:1,VAOA("A")>6:1,1:0) S VAX=.21
E S VAX="."_$P("33^34^211^331^311^25","^",+VAOA("A"))
S VAX(1)=VAX,VAX=$S($D(^DPT(DFN,VAX(1))):^(VAX(1)),1:"") I VAX(1)=.25 S VAX=$P(VAX,"^",1)_"^^"_$P(VAX,"^",2,99)
S VAX(2)=0 F I=3,4,5,6,7,8 S VAX(2)=VAX(2)+1,@VAV@($P(VAS,"^",VAX(2)))=$P(VAX,"^",I)
S @VAV@($P(VAS,"^",7))="",@VAV@($P(VAS,"^",8))=$P(VAX,"^",9),VAX(2)=8
F I=1,2 S VAX(2)=VAX(2)+1,@VAV@($P(VAS,"^",VAX(2)))=$P(VAX,"^",I)
I "^.311^.25"[("^"_VAX(1)_"^") S @VAV@($P(VAS,"^",10))=""
S VAZ=@VAV@($P(VAS,"^",5)) I VAZ,$D(^DIC(5,+VAZ,0)) S VAZ(1)=$P(^(0),"^",1),@VAV@($P(VAS,"^",5))=VAZ_"^"_VAZ(1)
Q
BLRDPT1 ; IHS/DIR/FJE - PATIENT VARIABLES ;
+1 ;;5.2;BLR;;NOV 01, 1997
+2 ;
+3 ;;MAS VERSION 5.0;
1 ;Demographic [DEM]
+1 NEW W,Z
+2 ;
+3 ; -- name [1 - NM]
+4 SET VAX=^DPT(DFN,0)
SET @VAV@($PIECE(VAS,"^",1))=$PIECE(VAX,"^")
+5 ;
+6 ; -- ssn [2 - SS]
+7 SET Z=$PIECE(VAX,"^",9)
IF Z]""
SET @VAV@($PIECE(VAS,"^",2))=Z_$SELECT(Z]"":"^"_$EXTRACT(Z,1,3)_"-"_$EXTRACT(Z,4,5)_"-"_$EXTRACT(Z,6,10),1:"")
+8 ;
+9 ; -- date of birth [2 - DB]
+10 SET Z=$PIECE(VAX,"^",3)
SET Y=Z
IF Y]""
XECUTE ^DD("DD")
SET @VAV@($PIECE(VAS,"^",3))=Z_"^"_Y
+11 ;
+12 ; -- age [4 - AG]
+13 SET W=$SELECT('$DATA(^DPT(DFN,.35)):"",'^(.35):"",1:+^(.35))
SET Y=$SELECT('W:DT,1:W)
IF Z]""
SET @VAV@($PIECE(VAS,"^",4))=$EXTRACT(Y,1,3)-$EXTRACT(Z,1,3)-($EXTRACT(Y,4,7)<$EXTRACT(Z,4,7))
+14 ;IHS/ANMC/CLS 10/15/94
IF @VAV@($PIECE(VAS,"^",4))<2
DO PAGE
+15 ;
+16 ; -- expired date [6 - EX]
+17 SET (Y,Z)=W
IF Y]""
XECUTE ^DD("DD")
IF Z]""
SET @VAV@($PIECE(VAS,"^",6))=Z_"^"_Y
+18 ;
+19 ; -- sex [5 - SX]
+20 SET Z=$PIECE(VAX,"^",2)
IF Z]""
SET @VAV@($PIECE(VAS,"^",5))=Z_"^"_$SELECT(Z="M":"MALE",Z="F":"FEMALE",1:"")
KILL Z
+21 ;
+22 ; -- remarks [7 - RE]
+23 SET @VAV@($PIECE(VAS,"^",7))=$PIECE(VAX,"^",10)
+24 ;
+25 ; -- race [8 - RA]
+26 SET Z=$PIECE(VAX,"^",6)
SET @VAV@($PIECE(VAS,"^",8))=Z_$SELECT($DATA(^DIC(10,+Z,0)):"^"_$PIECE(^(0),"^"),1:"")
+27 ;
+28 ; -- religion [9 - RP]
+29 SET Z=$PIECE(VAX,"^",8)
SET @VAV@($PIECE(VAS,"^",9))=Z_$SELECT($DATA(^DIC(13,+Z,0)):"^"_$PIECE(^(0),"^"),1:"")
+30 ;
+31 ; -- marital status [10 - MS]
+32 SET Z=$PIECE(VAX,"^",5)
SET @VAV@($PIECE(VAS,"^",10))=Z_$SELECT($DATA(^DIC(11,+Z,0)):"^"_$PIECE(^(0),"^"),1:"")
+33 ;
+34 ; -- IHS health record number [11 - HR]
+35 ;IHS/ANMC/CLS 10/15/94
SET Z=$SELECT($PIECE($GET(^AUPNPAT(+$GET(DFN),41,+$GET(DUZ(2)),0)),U,2)'="":$PIECE(^(0),U,2),1:"??")
SET @VAV@($PIECE(VAS,"^",11))=Z
+36 QUIT
+37 ;
PAGE ; -- IHS printable age ;IHS/ANMC/CLS 10/15/94
+1 NEW X,X1,X2,Y,AUX,D0
+2 SET D0=DFN
XECUTE ^DD(9000001,1102.98,9.3)
SET X=$PIECE(Y(9000001,1102.98,101),U,3)
SET Y=X
SET X=Y(9000001,1102.98,1)
SET X=X
SET X1=X
SET X2=Y
SET X=""
IF X2
IF X1
DO ^%DTC
SET AUX=X\365.25
SET X=$SELECT(AUX>2:AUX_" YRS",X<31:X_" DYS",1:X\30_" MOS")
KILL AUX
SET D0=Y(9000001,1102.98,80)
+3 SET @VAV@($PIECE(VAS,"^",4))=X
QUIT
+4 ;
2 ;Other Patient Variables [OPD]
+1 NEW W,Z
+2 SET VAX=^DPT(DFN,0)
+3 ;
+4 ; -- city of birth [1 - BC]
+5 SET @VAV@($PIECE(VAS,"^",1))=$PIECE(VAX,"^",11)
+6 ;
+7 ; -- state of birth [2 - BS]
+8 SET Z=$PIECE(VAX,"^",12)
SET @VAV@($PIECE(VAS,"^",2))=Z_$SELECT($DATA(^DIC(5,+Z,0)):"^"_$PIECE(^(0),"^",1),1:"")
+9 ;
+10 ; -- occupation [6 - OC]
+11 SET @VAV@($PIECE(VAS,"^",6))=$PIECE(VAX,"^",7)
+12 ;
+13 ; -- names
+14 SET VAX=$SELECT($DATA(^DPT(DFN,.24)):^(.24),1:"")
+15 ; father's [3 - FN]
SET @VAV@($PIECE(VAS,"^",3))=$PIECE(VAX,"^",1)
+16 ; mother's [4 - MN]
SET @VAV@($PIECE(VAS,"^",4))=$PIECE(VAX,"^",2)
+17 ; mother's maiden [5 - MM]
SET @VAV@($PIECE(VAS,"^",5))=$PIECE(VAX,"^",3)
+18 ;
+19 ; -- employment status [7 - ES]
+20 SET VAX=$SELECT($DATA(^DPT(DFN,.311)):^(.311),1:"")
SET W="EMPLOYED FULL TIME^EMPLOYED PART TIME^NOT EMPLOYED^SELF EMPLOYED^RETIRED^ACTIVE MILITARY DUTY^UNKNOWN"
+21 SET Z=$PIECE(VAX,"^",15)
SET @VAV@($PIECE(VAS,"^",7))=Z_$SELECT(Z:"^"_$PIECE(W,"^",Z),1:"")
+22 QUIT
+23 ;
3 ;Address [ADD]
+1 SET VABEG=$SELECT($DATA(VATEST("ADD",9)):VATEST("ADD",9),1:DT)
SET VAEND=$SELECT($DATA(VATEST("ADD",10)):VATEST("ADD",10),1:DT)
+2 IF $SELECT($DATA(VAPA("P")):1,'$DATA(^DPT(DFN,.121)):1,$PIECE(^(.121),"^",9)'="Y":1,'$PIECE(^(.121),"^",7):1,$PIECE(^(.121),"^",7)>VABEG:1,'$PIECE(^(.121),"^",8):0,1:$PIECE(^(.121),"^",8)<VAEND)
SET VAX=$SELECT($DATA(^DPT(DFN,.11)):^(.11),1:"")
SET VAX(1)=0
+3 IF '$TEST
SET VAX=$SELECT($DATA(^DPT(DFN,.121)):^(.121),1:"")
SET VAX(1)=1
+4 FOR I=1:1:6
SET VAZ=$PIECE(VAX,"^",I)
SET @VAV@($PIECE(VAS,"^",I))=VAZ
IF I=5
IF $DATA(^DIC(5,+VAZ,0))
SET VAZ=$PIECE(^(0),"^")
SET @VAV@($PIECE(VAS,"^",5))=@VAV@($PIECE(VAS,"^",5))_"^"_VAZ
+5 IF 'VAX(1)
SET VAZ=$PIECE(VAX,"^",7)
IF $DATA(^DIC(5,+$PIECE(VAX,"^",5),1,+VAZ,0))
SET VAZ=VAZ_"^"_$PIECE(^(0),"^",1)
SET @VAV@($PIECE(VAS,"^",7))=VAZ
IF $DATA(^DPT(DFN,.13))
SET @VAV@($PIECE(VAS,"^",8))=$PIECE(^(.13),"^",1)
GOTO Q3
+6 SET @VAV@($PIECE(VAS,"^",8))=$PIECE(VAX,"^",10)
+7 FOR I=7,8
SET VAZ=$PIECE(VAX,"^",I)
SET Y=VAZ
IF Y]""
XECUTE ^DD("DD")
SET @VAV@($PIECE(VAS,"^",I+2))=VAZ_"^"_Y
Q3 KILL VABEG,VAEND
QUIT
+1 ;
4 ;Other Address [OAD]
+1 IF $SELECT('$DATA(VAOA("A")):1,VAOA("A")<1:1,VAOA("A")>6:1,1:0)
SET VAX=.21
+2 IF '$TEST
SET VAX="."_$PIECE("33^34^211^331^311^25","^",+VAOA("A"))
+3 SET VAX(1)=VAX
SET VAX=$SELECT($DATA(^DPT(DFN,VAX(1))):^(VAX(1)),1:"")
IF VAX(1)=.25
SET VAX=$PIECE(VAX,"^",1)_"^^"_$PIECE(VAX,"^",2,99)
+4 SET VAX(2)=0
FOR I=3,4,5,6,7,8
SET VAX(2)=VAX(2)+1
SET @VAV@($PIECE(VAS,"^",VAX(2)))=$PIECE(VAX,"^",I)
+5 SET @VAV@($PIECE(VAS,"^",7))=""
SET @VAV@($PIECE(VAS,"^",8))=$PIECE(VAX,"^",9)
SET VAX(2)=8
+6 FOR I=1,2
SET VAX(2)=VAX(2)+1
SET @VAV@($PIECE(VAS,"^",VAX(2)))=$PIECE(VAX,"^",I)
+7 IF "^.311^.25"[("^"_VAX(1)_"^")
SET @VAV@($PIECE(VAS,"^",10))=""
+8 SET VAZ=@VAV@($PIECE(VAS,"^",5))
IF VAZ
IF $DATA(^DIC(5,+VAZ,0))
SET VAZ(1)=$PIECE(^(0),"^",1)
SET @VAV@($PIECE(VAS,"^",5))=VAZ_"^"_VAZ(1)
+9 QUIT
