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

VAFHLPI1.m

Go to the documentation of this file. 
  1. VAFHLPI1 ;BPFO/JRP - EXTENSION OF PID SEGMENT BUILDER VAFHLPID;5-DEC-2001 ; 21 Nov 2002  3:13 PM
  1.  ;;5.3;Registration;**415**;Aug 13, 1993
  1.  ;
  1.  Q
  1.  ;
  1. SEQ3(DFN,TYPE,HLENC,HLQ)     ;Build specified Patient ID (seq 3)
  1.  ;Input  : DFN - Pointer to Patient file (#2)
  1.  ;         TYPE - Which Patient ID to build
  1.  ;                  NI = ICN (default)
  1.  ;                  SS = SSN [with dashes]
  1.  ;                  PI = DFN
  1.  ;         HLENC - HL7 encoding characters (defaults to ~|\&)
  1.  ;         HLQ - HL7 null designation (defaults to "")
  1.  ;Output : Value for Patient ID (seq 3)
  1.  ;Notes  : HLQ will be returned on bad input
  1.  ;
  1.  ;Check input
  1.  S HLENC=$G(HLENC)
  1.  S:$L(HLENC)'=4 HLENC="~|\&"
  1.  S:'$D(HLQ) HLQ=""""""
  1.  S DFN=+$G(DFN)
  1.  I '$D(^DPT(DFN,0)) Q HLQ
  1.  S TYPE=$G(TYPE,"NI")
  1.  S:(",NI,SS,PI,"'[(","_TYPE_",")) TYPE="NI"
  1.  ;Declare variables
  1.  N COMP,REP,SUB,VALUE,ID,TMP
  1.  ;Break out encoding characters
  1.  S COMP=$E(HLENC,1)
  1.  S REP=$E(HLENC,2)
  1.  S SUB=$E(HLENC,4)
  1.  ;ID (comp 1)
  1.  S ID=""
  1.  ;ICN
  1.  I TYPE="NI" D
  1.  .;Don't transmit local ICNs
  1.  .I $$IFLOCAL^MPIF001(DFN) S ID="" Q
  1.  .S ID=$$GETICN^MPIF001(DFN)
  1.  .I (+ID)=-1 S ID=""
  1.  ;SSN
  1.  I TYPE="SS" D
  1.  .S ID=$P($G(^DPT(DFN,0)),"^",9)
  1.  .I ID'="" S ID=$E(ID,1,3)_"-"_$E(ID,4,5)_"-"_$E(ID,6,10)
  1.  ;DFN
  1.  I TYPE="PI" D
  1.  .S ID=DFN
  1.  S VALUE=$S(ID="":HLQ,1:ID)
  1.  ;Check Digit (comp 2) - not used for SSN
  1.  I TYPE'="SS" D
  1.  .;ICN - pull off check digit
  1.  .I TYPE="NI" S $P(VALUE,COMP,2)=$P(ID,"V",2) Q
  1.  .;DFN - calculate check digit
  1.  .;  Note: output of call includes Check Digit Scheme (comp 3)
  1.  .S TMP=$$M10^HLFNC(DFN,COMP)
  1.  .S $P(VALUE,COMP,2,3)=$P(TMP,COMP,2,3)
  1.  ;Assigning Authority (comp 4)
  1.  S TMP=""
  1.  S $P(TMP,SUB,1)=$S(TYPE="SS":"USSSA",1:"USVHA")
  1.  S $P(TMP,SUB,3)="L"
  1.  S $P(VALUE,COMP,4)=TMP
  1.  ;Identifier Type Code (comp 5)
  1.  S $P(VALUE,COMP,5)=TYPE
  1.  ;Assigning Facility (comp 6) - only used for DFN
  1.  I TYPE="PI" S $P(VALUE,COMP,6)=+$P($$SITE^VASITE(),"^",3)
  1.  ;Effective Date (comp 7) - only used for DFN
  1.  I TYPE="PI" D
  1.  .;DFN
  1.  .S TMP=$P($G(^DPT(DFN,0)),"^",16)
  1.  .S $P(VALUE,COMP,7)=$$HLDATE^HLFNC(TMP,"DT")
  1.  ;Return value
  1.  Q VALUE
  1.  ;
  1. SEQ10(HOW,HLQ)    ;Race
  1.  ;Input  : HOW - Qualifiers denoting how & which race to return
  1.  ;                N = Return new race value (2.02 multiple)
  1.  ;                T = Include text (components 2 & 5)
  1.  ;                B = Include second triplet (components 4 - 6)
  1.  ;               "" = Return historical value (.06 field)
  1.  ;         HLQ - HL7 null designation
  1.  ;Assumed: VADM() - Output of call to DEM^VADPT
  1.  ;Output : None - sets nodes in array VAFY
  1.  ;         VAFY(10,1..X) = Repetion X (if no components)
  1.  ;         VAFY(10,1..X,1..Y) = Component Y of repetiton X
  1.  ;Notes  : Validity and existance of input is assumed
  1.  ;       : Use of T & B qualifiers assume use of N qualifier
  1.  ;       : Assumes no individual component is greater than 245
  1.  ;         characters long
  1.  ;
  1.  ;Declare variables
  1.  N RACENUM,CNT,RACE,X
  1.  K VAFY(10)
  1.  I (HOW="")!((HOW'["N")&(HOW'["B")&(HOW'["T")) D  Q
  1.  .;Send historical value (if blank, send 7 (UNKNOWN))
  1.  .S X=$$PTR2CODE^DGUTL4(+VADM(8),1,1)
  1.  .S VAFY(10,1)=$S(X]"":X,1:7)
  1.  ;No values on file
  1.  I VADM(12)=0 D  Q
  1.  .;First triplet
  1.  .S VAFY(10,1,1)=HLQ
  1.  .S VAFY(10,1,2)=$S(HOW["T":HLQ,1:"")
  1.  .S VAFY(10,1,3)="0005"
  1.  .;Second triplet
  1.  .Q:HOW'["B"
  1.  .S VAFY(10,1,4)=HLQ
  1.  .S VAFY(10,1,5)=$S(HOW["T":HLQ,1:"")
  1.  .S VAFY(10,1,6)="CDC"
  1.  ;Loop through all races (CNT is repetition location)
  1.  S RACENUM=0
  1.  F CNT=1:1 S RACENUM=+$O(VADM(12,RACENUM)) Q:'RACENUM  D
  1.  .;Fabricate race value -> RACE-METHOD
  1.  .S RACE=$$PTR2CODE^DGUTL4(+VADM(12,RACENUM),1,2)
  1.  .S X=$$PTR2CODE^DGUTL4(+$G(VADM(12,RACENUM,1)),3,2)
  1.  .S:X="" X="UNK"
  1.  .S RACE=RACE_"-"_X
  1.  .;First triplet
  1.  .S VAFY(10,CNT,1)=RACE
  1.  .S VAFY(10,CNT,2)=$S(HOW["T":$P(VADM(12,RACENUM),"^",2),1:"")
  1.  .S VAFY(10,CNT,3)="0005"
  1.  .;Second triplet
  1.  .Q:HOW'["B"
  1.  .S X=$$PTR2CODE^DGUTL4(+VADM(12,RACENUM),1,3)
  1.  .S VAFY(10,CNT,4)=$S(X="":HLQ,1:X)
  1.  .S VAFY(10,CNT,5)=$S(HOW["T":$P(VADM(12,RACENUM),"^",2),1:"")
  1.  .S VAFY(10,CNT,6)="CDC"
  1.  Q
  1.  ;
  1. SEQ22(HOW,HLQ)    ;Ethnicity
  1.  ;Input  : HOW - Qualifiers denoting how to return ethnicity
  1.  ;                T = Include text (components 2 & 5)
  1.  ;                B = Include second triplet (components 4 - 6)
  1.  ;               "" = Only return components 1 & 3
  1.  ;         HLQ - HL7 null designation
  1.  ;Assumed: VADM() - Output of call to DEM^VADPT
  1.  ;Output : None - sets nodes in array VAFY
  1.  ;         VAFY(22,1,1..Y) = Component Y
  1.  ;Notes  : Validity and existance of input is assumed
  1.  ;       : Assumes no individual component is greater than 245
  1.  ;         characters long
  1.  ;
  1.  ;Declare variables
  1.  N ETHNIC,X,ETHNUM,CNT
  1.  K VAFY(22)
  1.  ;No value on file
  1.  I +VADM(11)=0 D  Q
  1.  .;First triplet
  1.  .S VAFY(22,1,1)=HLQ
  1.  .S VAFY(22,1,2)=$S(HOW["T":HLQ,1:"")
  1.  .S VAFY(22,1,3)="0189"
  1.  .;Second triplet
  1.  .Q:HOW'["B"
  1.  .S VAFY(22,1,4)=HLQ
  1.  .S VAFY(22,1,5)=$S(HOW["T":HLQ,1:"")
  1.  .S VAFY(22,1,6)="CDC"
  1.  ;Loop through all ethnicities (CNT is repetition location)
  1.  S ETHNUM=0
  1.  F CNT=1:1 S ETHNUM=+$O(VADM(11,ETHNUM)) Q:'ETHNUM  D
  1.  .;Fabricate ethnicity value -> ETHNICITY-METHOD
  1.  .S ETHNIC=$$PTR2CODE^DGUTL4(+VADM(11,ETHNUM),2,2)
  1.  .S X=$$PTR2CODE^DGUTL4(+$G(VADM(11,ETHNUM,1)),3,2)
  1.  .S:X="" X="UNK"
  1.  .S ETHNIC=ETHNIC_"-"_X
  1.  .;First triplet
  1.  .S VAFY(22,CNT,1)=ETHNIC
  1.  .S VAFY(22,CNT,2)=$S(HOW["T":$P(VADM(11,ETHNUM),"^",2),1:"")
  1.  .S VAFY(22,CNT,3)="0189"
  1.  .;Second triplet
  1.  .Q:HOW'["B"
  1.  .S X=$$PTR2CODE^DGUTL4(+VADM(11,ETHNUM),2,3)
  1.  .S VAFY(22,CNT,4)=$S(X="":HLQ,1:X)
  1.  .S VAFY(22,CNT,5)=$S(HOW["T":$P(VADM(11,ETHNUM),"^",2),1:"")
  1.  .S VAFY(22,CNT,6)="CDC"
  1.  Q