BLRDPT6 ; IHS/DIR/FJE - PATIENT ID VARIABLES @1200 ;
;;5.2;BLR;;NOV 01, 1997
;
;;MAS VERSION 5.0;
;
PID ;
13 ; -- Returns the patient id variables for DFN patient
; usually VA("PID")=123-45-6789 and VA("BID")="6789"
; for VA patients.
;
; -- Returns HRCN="123456" for IHS patients ;IHS/ANMC/CLS 11/14/94
;
; -- 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)
;
;S HRCN=$S($P($G(^AUPNPAT(+$G(DFN),41,+$G(DUZ(2)),0)),U,2)'="":$P(^(0),U,2),1:"??") ;IHS/ANMC/CLS 11/14/94
S HRCN=$S($P($G(^AUPNPAT(+$G(DFN),41,+$G(DUZ(2)),0)),"^",2)'="":$P(^(0),"^",2),1:"??") ;IHS/ANMC/CLS 11/01/95
;
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
BLRDPT6 ; IHS/DIR/FJE - PATIENT ID VARIABLES @1200 ;
+1 ;;5.2;BLR;;NOV 01, 1997
+2 ;
+3 ;;MAS VERSION 5.0;
+4 ;
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 HRCN="123456" for IHS patients ;IHS/ANMC/CLS 11/14/94
+5 ;
+6 ; -- Returns patient id variables as defined for the requested
+7 ; patient eligibility for DFN patient. The variable VAPTYP should
+8 ; contain the internal number of the desired patient eligibility.
+9 ;
+10 ; If the VAPTYP eligibility does not exist, then the standard
+11 ; values, as defined above, will be passed back.
+12 ;
+13 NEW X,L,B
KILL VAERR
SET (L,B)=""
+14 ; L = long id ; B = brief or short id
+15 SET VAERR=$SELECT('$DATA(DFN)#2:1,'$DATA(^DPT(+DFN,0)):1,1:0)
IF VAERR
GOTO PIDQ
+16 IF $DATA(VAPTYP)
IF $DATA(^DPT(DFN,"E",+VAPTYP,0))
SET X=^(0)
SET L=$PIECE(X,"^",3)
SET B=$PIECE(X,"^",4)
+17 ; -- set default id's
+18 IF L=""
IF $DATA(^DPT(DFN,.36))
SET X=^(.36)
IF +X
SET L=$PIECE(X,"^",3)
SET B=$PIECE(X,"^",4)
+19 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)
+20 ;
+21 ;S HRCN=$S($P($G(^AUPNPAT(+$G(DFN),41,+$G(DUZ(2)),0)),U,2)'="":$P(^(0),U,2),1:"??") ;IHS/ANMC/CLS 11/14/94
+22 ;IHS/ANMC/CLS 11/01/95
SET HRCN=$SELECT($PIECE($GET(^AUPNPAT(+$GET(DFN),41,+$GET(DUZ(2)),0)),"^",2)'="":$PIECE(^(0),"^",2),1:"??")
+23 ;
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
