LA7VHLU9 ;DALOI/JMC - HL7 segment builder utility ;09/08/15 15:44
;;5.2;AUTOMATED LAB INSTRUMENTS;**68,74,88**;Sep 27, 1994;Build 10
;
; Reference to NPI^XUSNPI supported by DBIA #4532
; Reference to QI^XUSNPI supported by DBIA #4532
;
;
XCN(LA7DUZ,LA7DIV,LA7FS,LA7ECH,LA7DMT,LA7IDTYP) ; Build composite ID and name for person
; Call with LA7DUZ = DUZ of person
; If not pointer to #200, then use as literal
; LA7DIV = Institution of user
; LA7FS = HL field separator
; LA7ECH = HL encoding characters
; LA7DMT = flag to indicate delimiters should be demoted
; LA7IDTYP = id type to return (0:DUZ 1:VPID 2:NPI)
;
N I,LA7CS,LA7NPI,LA7SITE,LA7VAF,LA7VPID,LA7X,LA7Y,LA7Z,NAME
;
S (LA7Y,LA7Z)="",LA7DMT=+$G(LA7DMT),LA7IDTYP=+$G(LA7IDTYP)
; If demoting delimiters then use sub-component delimiter instead of component delimiter.
S LA7CS=$E(LA7ECH,$S(LA7DMT=1:4,1:1))
;
; Check if this field has been built previously for this person
I LA7DUZ'="",$D(^TMP($J,"LA7VHLU","99VA200",LA7DUZ,LA7FS_LA7ECH,LA7DMT,LA7IDTYP)) S LA7Y=^TMP($J,"LA7VHLU","99VA200",LA7DUZ,LA7FS_LA7ECH,LA7DMT,LA7IDTYP)
;
; Build from file #200
I LA7Y="",LA7DUZ>0,LA7DUZ?1.N D
. S NAME("FILE")=200,NAME("FIELD")=.01,NAME("IENS")=LA7DUZ
. S LA7Z=$$HLNAME^XLFNAME(.NAME,"S",LA7CS)
. I LA7IDTYP=2 D Q:LA7NPI>0
. . S LA7NPI=$$NPI^XUSNPI("Individual_ID",LA7DUZ,DT)
. . I LA7NPI>0 S $P(LA7Y,LA7CS)=$P(LA7NPI,"^"),$P(LA7Y,LA7CS,9)="USDHHS",$P(LA7Y,LA7CS,11)=$E(LA7NPI,10),$P(LA7Y,LA7CS,12,13)="NPI"_LA7CS_"NPI"
. I LA7IDTYP>0 D Q:LA7VPID'=""
. . S LA7VPID=$$VPID^XUPS(LA7DUZ)
. . I LA7VPID'="" S $P(LA7Y,LA7CS)=LA7VPID,$P(LA7Y,LA7CS,9)="USVHA",$P(LA7Y,LA7CS,13)="PN"
. ; If no institution, use Kernel Site default
. I LA7DIV="" S LA7DIV=+$$KSP^XUPARAM("INST")
. S LA7SITE=$$RETFACID^LA7VHLU2(LA7DIV,0,1)
. I LA7SITE'="" D
. . S LA7VAF=$$GET1^DIQ(4,LA7DIV_",","AGENCY CODE","I")
. . I LA7VAF="V" S LA7SITE="VA"_LA7SITE
. . S LA7DUZ=LA7DUZ_"-"_LA7SITE,$P(LA7Y,LA7CS,8)="99VA4"
. S $P(LA7Y,LA7CS)=LA7DUZ
;
; If only name passed
I LA7Y="",'LA7DUZ D
. S NAME=LA7DUZ
. I LA7DUZ["[",LA7DUZ["]" D
. . S NAME=$P(LA7DUZ,"["),NAME(1)=$P(LA7DUZ,"[",2),NAME(1)=$P(NAME(1),"]")
. . I $P(NAME(1),":",2)?1(1"NPI",1"PN") S $P(LA7Y,LA7CS)=$P(NAME(1),":"),$P(LA7Y,LA7CS,9)=$P(NAME(1),":",4),$P(LA7Y,LA7CS,13)=$P(NAME(1),":",2)
. . I $P(NAME(1),":",2)?1(1"99"1.E,1"L") S $P(LA7Y,LA7CS)=$P(NAME(1),":"),$P(LA7Y,LA7CS,8)=$P(NAME(1),":",2)
. S NAME=$$CHKDATA^LA7VHLU3(NAME,LA7FS_LA7ECH)
. S LA7Z=$$HLNAME^XLFNAME(NAME,"S",LA7CS)
;
I LA7Z'="" F I=1:1:6 S $P(LA7Y,LA7CS,I+1)=$P(LA7Z,LA7CS,I)
;
; Save this field to TMP global to use for subsequent calls.
I LA7DUZ'="" S ^TMP($J,"LA7VHLU","99VA200",LA7DUZ,LA7FS_LA7ECH,LA7DMT,LA7IDTYP)=LA7Y
;
Q LA7Y
;
;
;
XCNTFM(LA7X,LA7ECH) ; Resolve XCN data type to FileMan (last name, first name, mi [id])
; Call with LA7X = HL7 field containing name
; LA7ECH = HL7 encoding characters
;
; Returns LA7Y = ID code^DUZ^FileMan name (DUZ=0 if name not found on local system).
;
N LA7DUZ,LA7IDC,LA7Y,LA7Z,X
;
;
S LA7DUZ=0
;
; Check for VPID
S (LA7IDC,LA7Z)=$P(LA7X,$E(LA7ECH))
I $P(LA7X,$E(LA7ECH),9)="USVHA",$P(LA7X,$E(LA7ECH),13)="PN" D
. S X=$$IEN^XUPS(LA7IDC)
. I X>0 S LA7DUZ=X
;
; Check for NPI
I $P(LA7X,$E(LA7ECH),9)="USDHHS",$P(LA7X,$E(LA7ECH),13)="NPI" D
. S X=$$QI^XUSNPI(LA7IDC)
. I $P(X,"^")="Individual_ID",$P(X,"^",2)>0 S LA7DUZ=$P(X,"^",2)
;
; Check for coding that indicates DUZ from a VA facility
I 'LA7DUZ,LA7Z?1.N1"-VA".NU,$$IEN^XUAF4($P(LA7Z,"-VA",2)) D
. N LA7DFLTINST,LA7J,LA7K
. S LA7Z(1)=$P(LA7Z,"-"),LA7Z(2)=$P(LA7Z,"-",2)
. S LA7DFLTINST=$$STA^XUAF4($$KSP^XUPARAM("INST"))
. I $E(LA7DFLTINST,1,3)'=$E(LA7Z(2),3,5) Q
. I $$ACTIVE^XUSER(LA7Z(1))'="" S LA7DUZ=LA7Z(1)
;
; Check if code resolves to a valid user.
I 'LA7DUZ,LA7Z=+LA7Z D
. S X=$$ACTIVE^XUSER(LA7Z)
. I X,$P(X,"^",2)'="" S LA7DUZ=LA7Z
;
S LA7Y=$$FMNAME^HLFNC($P(LA7X,$E(LA7ECH),2,6),LA7ECH)
; HL function sometimes returns trailing "," on name
S LA7Y=$$TRIM^XLFSTR(LA7Y,"R",",")
;
; Put identifying code at end of name in "[code:id type:va id type:issuing authority]".
I $P(LA7X,$E(LA7ECH))'="",LA7Y'="" D
. S X=""
. I $P(LA7X,$E(LA7ECH),8)?1(1"99"1.E,1"L") S X=$P(LA7X,$E(LA7ECH),8)
. I $P(LA7X,$E(LA7ECH),9)="USVHA",$P(LA7X,$E(LA7ECH),13)="PN" S X="PN:VPID:USVHA"
. I $P(LA7X,$E(LA7ECH),9)="USDHHS",$P(LA7X,$E(LA7ECH),13)="NPI" S X="NPI:NPI:USDHHS"
. S LA7Y=LA7Y_" ["_$P(LA7X,$E(LA7ECH))_":"_X_"]"
;
Q LA7IDC_"^"_LA7DUZ_"^"_LA7Y
;
;
;
XTN(LA7FN,LA7DA,LA7FLDSEQ,LA7MAXREP,LA7DT,LA7FS,LA7ECH) ; Build extended telecommunication number ;**88
; Call with LA7FN = Source File number
; Presently file #2 (PATIENT), #4 (INSTITUTION) or #200 (NEW PERSON)
; LA7DA = Entry in source file
; LA7FLDSEQ = List of file #200 fields and sequence to build in field separate by ";" e.g. ".138;.137;"
; LA7MAXREP = Maximum # of contact numbers to build in field.
; LA7DT = As of date in FileMan format
; LA7FS = HL field separator
; LA7ECH = HL encoding characters
;
; Returns extended telecommunication numbers
;
N LA7X,LA7Y
S LA7Y=""
I $G(LA7DT)="" S LA7DT=DT
I $G(LA7MAXREP)="" S LA7MAXREP=99
;
; Check if this field has been built previously for this entity
I LA7FN,LA7DA,$D(^TMP($J,"LA7VHLU","99VAXTN",LA7FN,LA7DA,LA7FS_LA7ECH)) S LA7Y=^TMP($J,"LA7VHLU","99VAXTN",LA7FN,LA7DA,LA7FS_LA7ECH)
;
; Build from file #200 the following fields:
; #.131 PHONE (HOME), #.132 OFFICE PHONE, #.133 PHONE #3, #.134 PHONE #4, #.135 COMMERCIAL PHONE, #.136 FAX NUMBER, #.137 VOICE PAGER, #.138 DIGITAL PAGER
;
I LA7Y="",LA7FN=200,LA7DA D
. N LA7ERR,LA7I,LA7J,LA7REP,LA7XTN
. I $G(LA7FLDSEQ)="" S LA7FLDSEQ=".132;.138;.137"
. D GETS^DIQ(200,LA7DA_",",LA7FLDSEQ,"E","LA7XTN(LA7DA)","LA7ERR")
. S LA7REP=0
. F LA7J=1:1 S LA7I=$P(LA7FLDSEQ,";",LA7J) Q:LA7I=""!(LA7REP=LA7MAXREP) I LA7XTN(LA7DA,200,LA7DA_",",LA7I,"E")'="" D
. . S LA7X="",LA7REP=LA7REP+1
. . S $P(LA7X,$E(LA7ECH),2)=$S(LA7I=.131:"PRN",LA7I=.138:"BPN",LA7I=.137:"BPN",1:"WPN")
. . S $P(LA7X,$E(LA7ECH),3)=$S(LA7I=.138:"BP",LA7I=.137:"BP",LA7X=.136:"FX",1:"PH")
. . S $P(LA7X,$E(LA7ECH),9)=$$CHKDATA^LA7VHLU3($$GET1^DID(200,LA7I,"","LABEL")_" (#"_LA7I_")",LA7FS_LA7ECH)
. . S $P(LA7X,$E(LA7ECH),12)=$$CHKDATA^LA7VHLU3(LA7XTN(LA7DA,200,LA7DA_",",LA7I,"E"),LA7FS_LA7ECH)
. . I LA7REP>1 S LA7Y=LA7Y_$E(LA7ECH,2)_LA7X
. . E S LA7Y=LA7X
;
; Build from file #2
I LA7Y="",LA7FN=2,LA7DA D
. N DFN,VAHOW,VAPA,VAERR,VAROOT,VATEST
. S DFN=LA7DA
. I LA7DT S (VATEST("ADD",9),VATEST("ADD",10))=LA7DT
. D ADD^VADPT
. I VAERR Q
. S $P(LA7Y,$E(LA7ECH),1)=""
. S $P(LA7Y,$E(LA7ECH),2)="PRN"
. S $P(LA7Y,$E(LA7ECH),3)="PH"
. S $P(LA7Y,$E(LA7ECH),12)=$$CHKDATA^LA7VHLU3($P(VAPA(8),"^"),LA7FS_LA7ECH)
;
; Build info from file #4
I LA7Y="",LA7FN=4,LA7DA D
. Q
;
; Save this field to TMP global to use for subsequent calls.
I LA7Y'="" S ^TMP($J,"LA7VHLU","99VAXTN",LA7FN,LA7DA,LA7FS_LA7ECH)=LA7Y
;
Q LA7Y ;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VHLU9 7274 printed Apr 09, 2024@20:49:29 Page 2
LA7VHLU9 ;DALOI/JMC - HL7 segment builder utility ;09/08/15 15:44
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**68,74,88**;Sep 27, 1994;Build 10
+2 ;
+3 ; Reference to NPI^XUSNPI supported by DBIA #4532
+4 ; Reference to QI^XUSNPI supported by DBIA #4532
+5 ;
+6 ;
XCN(LA7DUZ,LA7DIV,LA7FS,LA7ECH,LA7DMT,LA7IDTYP) ; Build composite ID and name for person
+1 ; Call with LA7DUZ = DUZ of person
+2 ; If not pointer to #200, then use as literal
+3 ; LA7DIV = Institution of user
+4 ; LA7FS = HL field separator
+5 ; LA7ECH = HL encoding characters
+6 ; LA7DMT = flag to indicate delimiters should be demoted
+7 ; LA7IDTYP = id type to return (0:DUZ 1:VPID 2:NPI)
+8 ;
+9 NEW I,LA7CS,LA7NPI,LA7SITE,LA7VAF,LA7VPID,LA7X,LA7Y,LA7Z,NAME
+10 ;
+11 SET (LA7Y,LA7Z)=""
SET LA7DMT=+$GET(LA7DMT)
SET LA7IDTYP=+$GET(LA7IDTYP)
+12 ; If demoting delimiters then use sub-component delimiter instead of component delimiter.
+13 SET LA7CS=$EXTRACT(LA7ECH,$SELECT(LA7DMT=1:4,1:1))
+14 ;
+15 ; Check if this field has been built previously for this person
+16 IF LA7DUZ'=""
IF $DATA(^TMP($JOB,"LA7VHLU","99VA200",LA7DUZ,LA7FS_LA7ECH,LA7DMT,LA7IDTYP))
SET LA7Y=^TMP($JOB,"LA7VHLU","99VA200",LA7DUZ,LA7FS_LA7ECH,LA7DMT,LA7IDTYP)
+17 ;
+18 ; Build from file #200
+19 IF LA7Y=""
IF LA7DUZ>0
IF LA7DUZ?1.N
Begin DoDot:1
+20 SET NAME("FILE")=200
SET NAME("FIELD")=.01
SET NAME("IENS")=LA7DUZ
+21 SET LA7Z=$$HLNAME^XLFNAME(.NAME,"S",LA7CS)
+22 IF LA7IDTYP=2
Begin DoDot:2
+23 SET LA7NPI=$$NPI^XUSNPI("Individual_ID",LA7DUZ,DT)
+24 IF LA7NPI>0
SET $PIECE(LA7Y,LA7CS)=$PIECE(LA7NPI,"^")
SET $PIECE(LA7Y,LA7CS,9)="USDHHS"
SET $PIECE(LA7Y,LA7CS,11)=$EXTRACT(LA7NPI,10)
SET $PIECE(LA7Y,LA7CS,12,13)="NPI"_LA7CS_"NPI"
End DoDot:2
if LA7NPI>0
QUIT
+25 IF LA7IDTYP>0
Begin DoDot:2
+26 SET LA7VPID=$$VPID^XUPS(LA7DUZ)
+27 IF LA7VPID'=""
SET $PIECE(LA7Y,LA7CS)=LA7VPID
SET $PIECE(LA7Y,LA7CS,9)="USVHA"
SET $PIECE(LA7Y,LA7CS,13)="PN"
End DoDot:2
if LA7VPID'=""
QUIT
+28 ; If no institution, use Kernel Site default
+29 IF LA7DIV=""
SET LA7DIV=+$$KSP^XUPARAM("INST")
+30 SET LA7SITE=$$RETFACID^LA7VHLU2(LA7DIV,0,1)
+31 IF LA7SITE'=""
Begin DoDot:2
+32 SET LA7VAF=$$GET1^DIQ(4,LA7DIV_",","AGENCY CODE","I")
+33 IF LA7VAF="V"
SET LA7SITE="VA"_LA7SITE
+34 SET LA7DUZ=LA7DUZ_"-"_LA7SITE
SET $PIECE(LA7Y,LA7CS,8)="99VA4"
End DoDot:2
+35 SET $PIECE(LA7Y,LA7CS)=LA7DUZ
End DoDot:1
+36 ;
+37 ; If only name passed
+38 IF LA7Y=""
IF 'LA7DUZ
Begin DoDot:1
+39 SET NAME=LA7DUZ
+40 IF LA7DUZ["["
IF LA7DUZ["]"
Begin DoDot:2
+41 SET NAME=$PIECE(LA7DUZ,"[")
SET NAME(1)=$PIECE(LA7DUZ,"[",2)
SET NAME(1)=$PIECE(NAME(1),"]")
+42 IF $PIECE(NAME(1),":",2)?1(1"NPI",1"PN")
SET $PIECE(LA7Y,LA7CS)=$PIECE(NAME(1),":")
SET $PIECE(LA7Y,LA7CS,9)=$PIECE(NAME(1),":",4)
SET $PIECE(LA7Y,LA7CS,13)=$PIECE(NAME(1),":",2)
+43 IF $PIECE(NAME(1),":",2)?1(1"99"1.E,1"L")
SET $PIECE(LA7Y,LA7CS)=$PIECE(NAME(1),":")
SET $PIECE(LA7Y,LA7CS,8)=$PIECE(NAME(1),":",2)
End DoDot:2
+44 SET NAME=$$CHKDATA^LA7VHLU3(NAME,LA7FS_LA7ECH)
+45 SET LA7Z=$$HLNAME^XLFNAME(NAME,"S",LA7CS)
End DoDot:1
+46 ;
+47 IF LA7Z'=""
FOR I=1:1:6
SET $PIECE(LA7Y,LA7CS,I+1)=$PIECE(LA7Z,LA7CS,I)
+48 ;
+49 ; Save this field to TMP global to use for subsequent calls.
+50 IF LA7DUZ'=""
SET ^TMP($JOB,"LA7VHLU","99VA200",LA7DUZ,LA7FS_LA7ECH,LA7DMT,LA7IDTYP)=LA7Y
+51 ;
+52 QUIT LA7Y
+53 ;
+54 ;
+55 ;
XCNTFM(LA7X,LA7ECH) ; Resolve XCN data type to FileMan (last name, first name, mi [id])
+1 ; Call with LA7X = HL7 field containing name
+2 ; LA7ECH = HL7 encoding characters
+3 ;
+4 ; Returns LA7Y = ID code^DUZ^FileMan name (DUZ=0 if name not found on local system).
+5 ;
+6 NEW LA7DUZ,LA7IDC,LA7Y,LA7Z,X
+7 ;
+8 ;
+9 SET LA7DUZ=0
+10 ;
+11 ; Check for VPID
+12 SET (LA7IDC,LA7Z)=$PIECE(LA7X,$EXTRACT(LA7ECH))
+13 IF $PIECE(LA7X,$EXTRACT(LA7ECH),9)="USVHA"
IF $PIECE(LA7X,$EXTRACT(LA7ECH),13)="PN"
Begin DoDot:1
+14 SET X=$$IEN^XUPS(LA7IDC)
+15 IF X>0
SET LA7DUZ=X
End DoDot:1
+16 ;
+17 ; Check for NPI
+18 IF $PIECE(LA7X,$EXTRACT(LA7ECH),9)="USDHHS"
IF $PIECE(LA7X,$EXTRACT(LA7ECH),13)="NPI"
Begin DoDot:1
+19 SET X=$$QI^XUSNPI(LA7IDC)
+20 IF $PIECE(X,"^")="Individual_ID"
IF $PIECE(X,"^",2)>0
SET LA7DUZ=$PIECE(X,"^",2)
End DoDot:1
+21 ;
+22 ; Check for coding that indicates DUZ from a VA facility
+23 IF 'LA7DUZ
IF LA7Z?1.N1"-VA".NU
IF $$IEN^XUAF4($PIECE(LA7Z,"-VA",2))
Begin DoDot:1
+24 NEW LA7DFLTINST,LA7J,LA7K
+25 SET LA7Z(1)=$PIECE(LA7Z,"-")
SET LA7Z(2)=$PIECE(LA7Z,"-",2)
+26 SET LA7DFLTINST=$$STA^XUAF4($$KSP^XUPARAM("INST"))
+27 IF $EXTRACT(LA7DFLTINST,1,3)'=$EXTRACT(LA7Z(2),3,5)
QUIT
+28 IF $$ACTIVE^XUSER(LA7Z(1))'=""
SET LA7DUZ=LA7Z(1)
End DoDot:1
+29 ;
+30 ; Check if code resolves to a valid user.
+31 IF 'LA7DUZ
IF LA7Z=+LA7Z
Begin DoDot:1
+32 SET X=$$ACTIVE^XUSER(LA7Z)
+33 IF X
IF $PIECE(X,"^",2)'=""
SET LA7DUZ=LA7Z
End DoDot:1
+34 ;
+35 SET LA7Y=$$FMNAME^HLFNC($PIECE(LA7X,$EXTRACT(LA7ECH),2,6),LA7ECH)
+36 ; HL function sometimes returns trailing "," on name
+37 SET LA7Y=$$TRIM^XLFSTR(LA7Y,"R",",")
+38 ;
+39 ; Put identifying code at end of name in "[code:id type:va id type:issuing authority]".
+40 IF $PIECE(LA7X,$EXTRACT(LA7ECH))'=""
IF LA7Y'=""
Begin DoDot:1
+41 SET X=""
+42 IF $PIECE(LA7X,$EXTRACT(LA7ECH),8)?1(1"99"1.E,1"L")
SET X=$PIECE(LA7X,$EXTRACT(LA7ECH),8)
+43 IF $PIECE(LA7X,$EXTRACT(LA7ECH),9)="USVHA"
IF $PIECE(LA7X,$EXTRACT(LA7ECH),13)="PN"
SET X="PN:VPID:USVHA"
+44 IF $PIECE(LA7X,$EXTRACT(LA7ECH),9)="USDHHS"
IF $PIECE(LA7X,$EXTRACT(LA7ECH),13)="NPI"
SET X="NPI:NPI:USDHHS"
+45 SET LA7Y=LA7Y_" ["_$PIECE(LA7X,$EXTRACT(LA7ECH))_":"_X_"]"
End DoDot:1
+46 ;
+47 QUIT LA7IDC_"^"_LA7DUZ_"^"_LA7Y
+48 ;
+49 ;
+50 ;
XTN(LA7FN,LA7DA,LA7FLDSEQ,LA7MAXREP,LA7DT,LA7FS,LA7ECH) ; Build extended telecommunication number ;**88
+1 ; Call with LA7FN = Source File number
+2 ; Presently file #2 (PATIENT), #4 (INSTITUTION) or #200 (NEW PERSON)
+3 ; LA7DA = Entry in source file
+4 ; LA7FLDSEQ = List of file #200 fields and sequence to build in field separate by ";" e.g. ".138;.137;"
+5 ; LA7MAXREP = Maximum # of contact numbers to build in field.
+6 ; LA7DT = As of date in FileMan format
+7 ; LA7FS = HL field separator
+8 ; LA7ECH = HL encoding characters
+9 ;
+10 ; Returns extended telecommunication numbers
+11 ;
+12 NEW LA7X,LA7Y
+13 SET LA7Y=""
+14 IF $GET(LA7DT)=""
SET LA7DT=DT
+15 IF $GET(LA7MAXREP)=""
SET LA7MAXREP=99
+16 ;
+17 ; Check if this field has been built previously for this entity
+18 IF LA7FN
IF LA7DA
IF $DATA(^TMP($JOB,"LA7VHLU","99VAXTN",LA7FN,LA7DA,LA7FS_LA7ECH))
SET LA7Y=^TMP($JOB,"LA7VHLU","99VAXTN",LA7FN,LA7DA,LA7FS_LA7ECH)
+19 ;
+20 ; Build from file #200 the following fields:
+21 ; #.131 PHONE (HOME), #.132 OFFICE PHONE, #.133 PHONE #3, #.134 PHONE #4, #.135 COMMERCIAL PHONE, #.136 FAX NUMBER, #.137 VOICE PAGER, #.138 DIGITAL PAGER
+22 ;
+23 IF LA7Y=""
IF LA7FN=200
IF LA7DA
Begin DoDot:1
+24 NEW LA7ERR,LA7I,LA7J,LA7REP,LA7XTN
+25 IF $GET(LA7FLDSEQ)=""
SET LA7FLDSEQ=".132;.138;.137"
+26 DO GETS^DIQ(200,LA7DA_",",LA7FLDSEQ,"E","LA7XTN(LA7DA)","LA7ERR")
+27 SET LA7REP=0
+28 FOR LA7J=1:1
SET LA7I=$PIECE(LA7FLDSEQ,";",LA7J)
if LA7I=""!(LA7REP=LA7MAXREP)
QUIT
IF LA7XTN(LA7DA,200,LA7DA_",",LA7I,"E")'=""
Begin DoDot:2
+29 SET LA7X=""
SET LA7REP=LA7REP+1
+30 SET $PIECE(LA7X,$EXTRACT(LA7ECH),2)=$SELECT(LA7I=.131:"PRN",LA7I=.138:"BPN",LA7I=.137:"BPN",1:"WPN")
+31 SET $PIECE(LA7X,$EXTRACT(LA7ECH),3)=$SELECT(LA7I=.138:"BP",LA7I=.137:"BP",LA7X=.136:"FX",1:"PH")
+32 SET $PIECE(LA7X,$EXTRACT(LA7ECH),9)=$$CHKDATA^LA7VHLU3($$GET1^DID(200,LA7I,"","LABEL")_" (#"_LA7I_")",LA7FS_LA7ECH)
+33 SET $PIECE(LA7X,$EXTRACT(LA7ECH),12)=$$CHKDATA^LA7VHLU3(LA7XTN(LA7DA,200,LA7DA_",",LA7I,"E"),LA7FS_LA7ECH)
+34 IF LA7REP>1
SET LA7Y=LA7Y_$EXTRACT(LA7ECH,2)_LA7X
+35 IF '$TEST
SET LA7Y=LA7X
End DoDot:2
End DoDot:1
+36 ;
+37 ; Build from file #2
+38 IF LA7Y=""
IF LA7FN=2
IF LA7DA
Begin DoDot:1
+39 NEW DFN,VAHOW,VAPA,VAERR,VAROOT,VATEST
+40 SET DFN=LA7DA
+41 IF LA7DT
SET (VATEST("ADD",9),VATEST("ADD",10))=LA7DT
+42 DO ADD^VADPT
+43 IF VAERR
QUIT
+44 SET $PIECE(LA7Y,$EXTRACT(LA7ECH),1)=""
+45 SET $PIECE(LA7Y,$EXTRACT(LA7ECH),2)="PRN"
+46 SET $PIECE(LA7Y,$EXTRACT(LA7ECH),3)="PH"
+47 SET $PIECE(LA7Y,$EXTRACT(LA7ECH),12)=$$CHKDATA^LA7VHLU3($PIECE(VAPA(8),"^"),LA7FS_LA7ECH)
End DoDot:1
+48 ;
+49 ; Build info from file #4
+50 IF LA7Y=""
IF LA7FN=4
IF LA7DA
Begin DoDot:1
+51 QUIT
End DoDot:1
+52 ;
+53 ; Save this field to TMP global to use for subsequent calls.
+54 IF LA7Y'=""
SET ^TMP($JOB,"LA7VHLU","99VAXTN",LA7FN,LA7DA,LA7FS_LA7ECH)=LA7Y
+55 ;
+56 ;
QUIT LA7Y
