Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: VADPT6

VADPT6.m

Go to the documentation of this file.
  1. VADPT6 ;ALB/MJK - PATIENT ID VARIABLES ; 12 AUG 89 @1200
  1. ;;5.3;Registration;;Aug 13, 1993
  1. ;
  1. PID ;
  1. 13 ; -- Returns the patient id variables for DFN patient
  1. ; usually VA("PID")=123-45-6789 and VA("BID")="6789"
  1. ; for VA patients.
  1. ;
  1. ; -- Returns patient id variables as defined for the requested
  1. ; patient eligibility for DFN patient. The variable VAPTYP should
  1. ; contain the internal number of the desired patient eligibility.
  1. ;
  1. ; If the VAPTYP eligibility does not exist, then the standard
  1. ; values, as defined above, will be passed back.
  1. ;
  1. N X,L,B K VAERR S (L,B)=""
  1. ; L = long id ; B = brief or short id
  1. S VAERR=$S('$D(DFN)#2:1,'$D(^DPT(+DFN,0)):1,1:0) I VAERR G PIDQ
  1. I $D(VAPTYP),$D(^DPT(DFN,"E",+VAPTYP,0)) S X=^(0),L=$P(X,"^",3),B=$P(X,"^",4)
  1. ; -- set default id's
  1. I L="",$D(^DPT(DFN,.36)) S X=^(.36) I +X S L=$P(X,"^",3),B=$P(X,"^",4)
  1. 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)
  1. ;
  1. PIDQ S VA("PID")=L,VA("BID")=B Q
  1. ;
  1. SET ;-- execute id format specific long id, short id and x-ref set logic
  1. ; input: VADFN == DFN
  1. ;
  1. Q:'$D(^DPT(VADFN,"E",0))
  1. N X,DA S DA(1)=VADFN
  1. F DA=0:0 S DA=$O(^DPT(DA(1),"E",DA)) Q:'DA I $D(^(DA,0)) D SET1
  1. K X,DA
  1. Q
  1. SET1 ;
  1. D CHK G SET1Q:'VAFMT
  1. ; -- calc/store long id
  1. S X=""
  1. I $D(^DIC(8.2,VAFMT,"LONG")) X ^("LONG") S $P(^DPT(DA(1),"E",DA,0),U,3)=X
  1. ; -- long id x-refs (set logic)
  1. S VAX=X G SET1Q:X=""
  1. F VAIX=0:0 S VAIX=$O(^DD(2.0361,.03,1,VAIX)) Q:'VAIX X ^(VAIX,1) S X=VAX
  1. ; -- short id x-refs (set logic)
  1. S (VAX,X)=$P(^DPT(DA(1),"E",DA,0),U,4) G SET1Q:X=""
  1. F VAIX=0:0 S VAIX=$O(^DD(2.0361,.04,1,VAIX)) Q:'VAIX X ^(VAIX,1) S X=VAX
  1. SET1Q K VAIX,VAX,X,VAFMT
  1. Q
  1. ;
  1. KILL ; -- execute id format specific x-ref kill logic
  1. ; input: VADFN ==> DFN
  1. ;
  1. Q:'$D(^DPT(VADFN,"E",0))
  1. N X,DA S DA(1)=VADFN
  1. F DA=0:0 S DA=$O(^DPT(DA(1),"E",DA)) Q:'DA I $D(^(DA,0)) D KILL1
  1. K X,DA
  1. Q
  1. ;
  1. KILL1 ;
  1. D CHK G KILL1Q:'VAFMT
  1. ; -- short id x-ref (kill logic)
  1. S (VAX,X)=$P(^DPT(DA(1),"E",DA,0),U,4) G KILL2:X=""
  1. F VAIX=0:0 S VAIX=$O(^DD(2.0361,.04,1,VAIX)) Q:'VAIX X ^(VAIX,2) S X=VAX
  1. S $P(^DPT(DA(1),"E",DA,0),U,4)=""
  1. KILL2 ; -- long id (kill logic)
  1. S (VAX,X)=$P(^DPT(DA(1),"E",DA,0),U,3) G KILL1Q:X=""
  1. F VAIX=0:0 S VAIX=$O(^DD(2.0361,.03,1,VAIX)) Q:'VAIX X ^(VAIX,2) S X=VAX
  1. S $P(^DPT(DA(1),"E",DA,0),U,3)=""
  1. KILL1Q K VAX,VAIX,VAFMT
  1. Q
  1. ;
  1. CHK ; -- ok to proceed ; fmt defined
  1. S VAFMT=0
  1. I $D(^DIC(8,DA,0)) S VAFMT=+$P(^(0),U,10),VAFMT=$S($D(^DIC(8.2,VAFMT,0)):VAFMT,1:0)
  1. Q