- 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
