- 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 Jan 18, 2025@04:02:01 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