| [613] | 1 | VADPT6 ;ALB/MJK - PATIENT ID VARIABLES ; 12 AUG 89 @1200
|
|---|
| 2 | ;;5.3;Registration;;Aug 13, 1993
|
|---|
| 3 | ;
|
|---|
| 4 | PID ;
|
|---|
| 5 | 13 ; -- Returns the patient id variables for DFN patient
|
|---|
| 6 | ; usually VA("PID")=123-45-6789 and VA("BID")="6789"
|
|---|
| 7 | ; for VA patients.
|
|---|
| 8 | ;
|
|---|
| 9 | ; -- Returns patient id variables as defined for the requested
|
|---|
| 10 | ; patient eligibility for DFN patient. The variable VAPTYP should
|
|---|
| 11 | ; contain the internal number of the desired patient eligibility.
|
|---|
| 12 | ;
|
|---|
| 13 | ; If the VAPTYP eligibility does not exist, then the standard
|
|---|
| 14 | ; values, as defined above, will be passed back.
|
|---|
| 15 | ;
|
|---|
| 16 | N X,L,B K VAERR S (L,B)=""
|
|---|
| 17 | ; L = long id ; B = brief or short id
|
|---|
| 18 | S VAERR=$S('$D(DFN)#2:1,'$D(^DPT(+DFN,0)):1,1:0) I VAERR G PIDQ
|
|---|
| 19 | I $D(VAPTYP),$D(^DPT(DFN,"E",+VAPTYP,0)) S X=^(0),L=$P(X,"^",3),B=$P(X,"^",4)
|
|---|
| 20 | ; -- set default id's
|
|---|
| 21 | I L="",$D(^DPT(DFN,.36)) S X=^(.36) I +X S L=$P(X,"^",3),B=$P(X,"^",4)
|
|---|
| 22 | 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)
|
|---|
| 23 | ;
|
|---|
| 24 | PIDQ S VA("PID")=L,VA("BID")=B Q
|
|---|
| 25 | ;
|
|---|
| 26 | SET ;-- execute id format specific long id, short id and x-ref set logic
|
|---|
| 27 | ; input: VADFN == DFN
|
|---|
| 28 | ;
|
|---|
| 29 | Q:'$D(^DPT(VADFN,"E",0))
|
|---|
| 30 | N X,DA S DA(1)=VADFN
|
|---|
| 31 | F DA=0:0 S DA=$O(^DPT(DA(1),"E",DA)) Q:'DA I $D(^(DA,0)) D SET1
|
|---|
| 32 | K X,DA
|
|---|
| 33 | Q
|
|---|
| 34 | SET1 ;
|
|---|
| 35 | D CHK G SET1Q:'VAFMT
|
|---|
| 36 | ; -- calc/store long id
|
|---|
| 37 | S X=""
|
|---|
| 38 | I $D(^DIC(8.2,VAFMT,"LONG")) X ^("LONG") S $P(^DPT(DA(1),"E",DA,0),U,3)=X
|
|---|
| 39 | ; -- long id x-refs (set logic)
|
|---|
| 40 | S VAX=X G SET1Q:X=""
|
|---|
| 41 | F VAIX=0:0 S VAIX=$O(^DD(2.0361,.03,1,VAIX)) Q:'VAIX X ^(VAIX,1) S X=VAX
|
|---|
| 42 | ; -- short id x-refs (set logic)
|
|---|
| 43 | S (VAX,X)=$P(^DPT(DA(1),"E",DA,0),U,4) G SET1Q:X=""
|
|---|
| 44 | F VAIX=0:0 S VAIX=$O(^DD(2.0361,.04,1,VAIX)) Q:'VAIX X ^(VAIX,1) S X=VAX
|
|---|
| 45 | SET1Q K VAIX,VAX,X,VAFMT
|
|---|
| 46 | Q
|
|---|
| 47 | ;
|
|---|
| 48 | KILL ; -- execute id format specific x-ref kill logic
|
|---|
| 49 | ; input: VADFN ==> DFN
|
|---|
| 50 | ;
|
|---|
| 51 | Q:'$D(^DPT(VADFN,"E",0))
|
|---|
| 52 | N X,DA S DA(1)=VADFN
|
|---|
| 53 | F DA=0:0 S DA=$O(^DPT(DA(1),"E",DA)) Q:'DA I $D(^(DA,0)) D KILL1
|
|---|
| 54 | K X,DA
|
|---|
| 55 | Q
|
|---|
| 56 | ;
|
|---|
| 57 | KILL1 ;
|
|---|
| 58 | D CHK G KILL1Q:'VAFMT
|
|---|
| 59 | ; -- short id x-ref (kill logic)
|
|---|
| 60 | S (VAX,X)=$P(^DPT(DA(1),"E",DA,0),U,4) G KILL2:X=""
|
|---|
| 61 | F VAIX=0:0 S VAIX=$O(^DD(2.0361,.04,1,VAIX)) Q:'VAIX X ^(VAIX,2) S X=VAX
|
|---|
| 62 | S $P(^DPT(DA(1),"E",DA,0),U,4)=""
|
|---|
| 63 | KILL2 ; -- long id (kill logic)
|
|---|
| 64 | S (VAX,X)=$P(^DPT(DA(1),"E",DA,0),U,3) G KILL1Q:X=""
|
|---|
| 65 | F VAIX=0:0 S VAIX=$O(^DD(2.0361,.03,1,VAIX)) Q:'VAIX X ^(VAIX,2) S X=VAX
|
|---|
| 66 | S $P(^DPT(DA(1),"E",DA,0),U,3)=""
|
|---|
| 67 | KILL1Q K VAX,VAIX,VAFMT
|
|---|
| 68 | Q
|
|---|
| 69 | ;
|
|---|
| 70 | CHK ; -- ok to proceed ; fmt defined
|
|---|
| 71 | S VAFMT=0
|
|---|
| 72 | I $D(^DIC(8,DA,0)) S VAFMT=+$P(^(0),U,10),VAFMT=$S($D(^DIC(8.2,VAFMT,0)):VAFMT,1:0)
|
|---|
| 73 | Q
|
|---|
