- 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 Feb 18, 2025@23:06:38 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