VADPT6 ;ALB/MJK - PATIENT ID VARIABLES ; 12 AUG 89 @1200
;;5.3;Registration;;Aug 13, 1993
;
PID ;
13 ; -- Returns the patient id variables for DFN patient
; usually VA("PID")=123-45-6789 and VA("BID")="6789"
; for VA patients.
;
; -- Returns patient id variables as defined for the requested
; patient eligibility for DFN patient. The variable VAPTYP should
; contain the internal number of the desired patient eligibility.
;
; If the VAPTYP eligibility does not exist, then the standard
; values, as defined above, will be passed back.
;
N X,L,B K VAERR S (L,B)=""
; L = long id ; B = brief or short id
S VAERR=$S('$D(DFN)#2:1,'$D(^DPT(+DFN,0)):1,1:0) I VAERR G PIDQ
I $D(VAPTYP),$D(^DPT(DFN,"E",+VAPTYP,0)) S X=^(0),L=$P(X,"^",3),B=$P(X,"^",4)
; -- set default id's
I L="",$D(^DPT(DFN,.36)) S X=^(.36) I +X S L=$P(X,"^",3),B=$P(X,"^",4)
I L="" S X=$P(^DPT(DFN,0),"^",9) I X]"" S L=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10),B=$E(X,6,10)
;
PIDQ S VA("PID")=L,VA("BID")=B Q
;
SET ;-- execute id format specific long id, short id and x-ref set logic
; input: VADFN == DFN
;
Q:'$D(^DPT(VADFN,"E",0))
N X,DA S DA(1)=VADFN
F DA=0:0 S DA=$O(^DPT(DA(1),"E",DA)) Q:'DA I $D(^(DA,0)) D SET1
K X,DA
Q
SET1 ;
D CHK G SET1Q:'VAFMT
; -- calc/store long id
S X=""
I $D(^DIC(8.2,VAFMT,"LONG")) X ^("LONG") S $P(^DPT(DA(1),"E",DA,0),U,3)=X
; -- long id x-refs (set logic)
S VAX=X G SET1Q:X=""
F VAIX=0:0 S VAIX=$O(^DD(2.0361,.03,1,VAIX)) Q:'VAIX X ^(VAIX,1) S X=VAX
; -- short id x-refs (set logic)
S (VAX,X)=$P(^DPT(DA(1),"E",DA,0),U,4) G SET1Q:X=""
F VAIX=0:0 S VAIX=$O(^DD(2.0361,.04,1,VAIX)) Q:'VAIX X ^(VAIX,1) S X=VAX
SET1Q K VAIX,VAX,X,VAFMT
Q
;
KILL ; -- execute id format specific x-ref kill logic
; input: VADFN ==> DFN
;
Q:'$D(^DPT(VADFN,"E",0))
N X,DA S DA(1)=VADFN
F DA=0:0 S DA=$O(^DPT(DA(1),"E",DA)) Q:'DA I $D(^(DA,0)) D KILL1
K X,DA
Q
;
KILL1 ;
D CHK G KILL1Q:'VAFMT
; -- short id x-ref (kill logic)
S (VAX,X)=$P(^DPT(DA(1),"E",DA,0),U,4) G KILL2:X=""
F VAIX=0:0 S VAIX=$O(^DD(2.0361,.04,1,VAIX)) Q:'VAIX X ^(VAIX,2) S X=VAX
S $P(^DPT(DA(1),"E",DA,0),U,4)=""
KILL2 ; -- long id (kill logic)
S (VAX,X)=$P(^DPT(DA(1),"E",DA,0),U,3) G KILL1Q:X=""
F VAIX=0:0 S VAIX=$O(^DD(2.0361,.03,1,VAIX)) Q:'VAIX X ^(VAIX,2) S X=VAX
S $P(^DPT(DA(1),"E",DA,0),U,3)=""
KILL1Q K VAX,VAIX,VAFMT
Q
;
CHK ; -- ok to proceed ; fmt defined
S VAFMT=0
I $D(^DIC(8,DA,0)) S VAFMT=+$P(^(0),U,10),VAFMT=$S($D(^DIC(8.2,VAFMT,0)):VAFMT,1:0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVADPT6 2575 printed Sep 23, 2025@20:37:14 Page 2
VADPT6 ;ALB/MJK - PATIENT ID VARIABLES ; 12 AUG 89 @1200
+1 ;;5.3;Registration;;Aug 13, 1993
+2 ;
PID ;
13 ; -- Returns the patient id variables for DFN patient
+1 ; usually VA("PID")=123-45-6789 and VA("BID")="6789"
+2 ; for VA patients.
+3 ;
+4 ; -- Returns patient id variables as defined for the requested
+5 ; patient eligibility for DFN patient. The variable VAPTYP should
+6 ; contain the internal number of the desired patient eligibility.
+7 ;
+8 ; If the VAPTYP eligibility does not exist, then the standard
+9 ; values, as defined above, will be passed back.
+10 ;
+11 NEW X,L,B
KILL VAERR
SET (L,B)=""
+12 ; L = long id ; B = brief or short id
+13 SET VAERR=$SELECT('$DATA(DFN)#2:1,'$DATA(^DPT(+DFN,0)):1,1:0)
IF VAERR
GOTO PIDQ
+14 IF $DATA(VAPTYP)
IF $DATA(^DPT(DFN,"E",+VAPTYP,0))
SET X=^(0)
SET L=$PIECE(X,"^",3)
SET B=$PIECE(X,"^",4)
+15 ; -- set default id's
+16 IF L=""
IF $DATA(^DPT(DFN,.36))
SET X=^(.36)
IF +X
SET L=$PIECE(X,"^",3)
SET B=$PIECE(X,"^",4)
+17 IF L=""
SET X=$PIECE(^DPT(DFN,0),"^",9)
IF X]""
SET L=$EXTRACT(X,1,3)_"-"_$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,10)
SET B=$EXTRACT(X,6,10)
+18 ;
PIDQ SET VA("PID")=L
SET VA("BID")=B
QUIT
+1 ;
SET ;-- execute id format specific long id, short id and x-ref set logic
+1 ; input: VADFN == DFN
+2 ;
+3 if '$DATA(^DPT(VADFN,"E",0))
QUIT
+4 NEW X,DA
SET DA(1)=VADFN
+5 FOR DA=0:0
SET DA=$ORDER(^DPT(DA(1),"E",DA))
if 'DA
QUIT
IF $DATA(^(DA,0))
DO SET1
+6 KILL X,DA
+7 QUIT
SET1 ;
+1 DO CHK
if 'VAFMT
GOTO SET1Q
+2 ; -- calc/store long id
+3 SET X=""
+4 IF $DATA(^DIC(8.2,VAFMT,"LONG"))
XECUTE ^("LONG")
SET $PIECE(^DPT(DA(1),"E",DA,0),U,3)=X
+5 ; -- long id x-refs (set logic)
+6 SET VAX=X
if X=""
GOTO SET1Q
+7 FOR VAIX=0:0
SET VAIX=$ORDER(^DD(2.0361,.03,1,VAIX))
if 'VAIX
QUIT
XECUTE ^(VAIX,1)
SET X=VAX
+8 ; -- short id x-refs (set logic)
+9 SET (VAX,X)=$PIECE(^DPT(DA(1),"E",DA,0),U,4)
if X=""
GOTO SET1Q
+10 FOR VAIX=0:0
SET VAIX=$ORDER(^DD(2.0361,.04,1,VAIX))
if 'VAIX
QUIT
XECUTE ^(VAIX,1)
SET X=VAX
SET1Q KILL VAIX,VAX,X,VAFMT
+1 QUIT
+2 ;
KILL ; -- execute id format specific x-ref kill logic
+1 ; input: VADFN ==> DFN
+2 ;
+3 if '$DATA(^DPT(VADFN,"E",0))
QUIT
+4 NEW X,DA
SET DA(1)=VADFN
+5 FOR DA=0:0
SET DA=$ORDER(^DPT(DA(1),"E",DA))
if 'DA
QUIT
IF $DATA(^(DA,0))
DO KILL1
+6 KILL X,DA
+7 QUIT
+8 ;
KILL1 ;
+1 DO CHK
if 'VAFMT
GOTO KILL1Q
+2 ; -- short id x-ref (kill logic)
+3 SET (VAX,X)=$PIECE(^DPT(DA(1),"E",DA,0),U,4)
if X=""
GOTO KILL2
+4 FOR VAIX=0:0
SET VAIX=$ORDER(^DD(2.0361,.04,1,VAIX))
if 'VAIX
QUIT
XECUTE ^(VAIX,2)
SET X=VAX
+5 SET $PIECE(^DPT(DA(1),"E",DA,0),U,4)=""
KILL2 ; -- long id (kill logic)
+1 SET (VAX,X)=$PIECE(^DPT(DA(1),"E",DA,0),U,3)
if X=""
GOTO KILL1Q
+2 FOR VAIX=0:0
SET VAIX=$ORDER(^DD(2.0361,.03,1,VAIX))
if 'VAIX
QUIT
XECUTE ^(VAIX,2)
SET X=VAX
+3 SET $PIECE(^DPT(DA(1),"E",DA,0),U,3)=""
KILL1Q KILL VAX,VAIX,VAFMT
+1 QUIT
+2 ;
CHK ; -- ok to proceed ; fmt defined
+1 SET VAFMT=0
+2 IF $DATA(^DIC(8,DA,0))
SET VAFMT=+$PIECE(^(0),U,10)
SET VAFMT=$SELECT($DATA(^DIC(8.2,VAFMT,0)):VAFMT,1:0)
+3 QUIT
