XUMFQR ;ISS/RAM - Master File Query Response ;02/10/2017
;;8.0;KERNEL;**407,502,676**;Jul 10, 1995;Build 8
;Per VHA Directive 10-92-142, this routine should not be modified
;
Q
;
MAIN ; -- main
;
N FIELD1,IDX,IDX1,NAME1,SUBFILE1,DATA1,IEN1,TYP1,MKEY,MKEY1,TYP,VUID,VUID1
N MFI,SEQ,NAME,QRD,SEQ,SUBFILE,IEN,CNT,DATA,ERROR,SORTBY,FILTERBY,FILTER,ERRCNT
;
D INIT,PROCESS,MFR,SEND,EXIT
;
Q
;
INIT ; -- initialize
;
K ^TMP("HLA",$J)
;
S ERROR=0,CNT=1,ERRCNT=0
;
S HLFS=HL("FS"),HLCS=$E(HL("ECH")),HLSCS=$E(HL("ECH"),4)
;
Q
;
PROCESS ; -- pull message text
;
F X HLNEXT Q:HLQUIT'>0 D
.Q:$P(HLNODE,HLFS)=""
.Q:"^MSH^MSA^QRD^"'[(U_$P(HLNODE,HLFS)_U)
.D @($P(HLNODE,HLFS))
;
Q
;
MSH ; -- MSH segment
;
Q
;
QRD ; -- QRD segment
;
Q:ERROR
;
S MFI=$P(HLNODE,HLFS,10),FILTER=$P(MFI,HLCS,2),MFI=$P(MFI,HLCS)
I MFI="" S ERROR="1^MFI not resolved HLNODE: "_$TR(HLNODE,HLFS,"#") Q
S IFN=$O(^DIC(4.001,"MFID",MFI,0))
I 'IFN S ERROR="1^IFN not resolved HLNODE: "_$TR(HLNODE,HLFS,"#") Q
I '$$VFILE^DILFD(IFN) S ERROR="1^invalid file number" Q
S DATA=$G(^DIC(4.001,+IFN,0)),SORTBY=$P(DATA,U,8),FILTERBY=$P(DATA,U,9)
;
; -- get root of file
S ROOT=$$ROOT^DILFD(IFN,,1)
;
S QRD=HLNODE
;
Q
;
MFR ; -- response
;
D MSA,QRD1,MFI,MFE
;
Q
;
MSA ; -- Acknowledgement
;
N X
S X="MSA"_HLFS_$S(ERROR:"AE",1:"AA")_HLFS_HL("MID")_HLFS_$P(ERROR,U,2)
S ^TMP("HLA",$J,CNT)=X
S CNT=CNT+1
;
Q
;
QRD1 ; -- query definition segment
;
Q:ERROR
;
S ^TMP("HLA",$J,CNT)=$G(QRD)
S CNT=CNT+1
;
Q
;
MFI ; master file identifier segment
;
Q:ERROR
;
S ^TMP("HLA",$J,CNT)=$$MFI^XUMFMFI(MFI,"Standard Terminology","MUP",$$NOW^XLFDT,$$NOW^XLFDT,"NE")
S CNT=CNT+1
;
Q
;
MFE ; master file entry segment
;
Q:ERROR
;
S VUID=0 F S VUID=$O(@ROOT@($S(SORTBY'="":SORTBY,1:"AMASTERVUID"),VUID)) Q:'VUID D Q:ERROR
.I SORTBY="" S IEN=$O(@ROOT@("AMASTERVUID",VUID,1,0)) Q:'IEN
.I SORTBY'="" S IEN=$O(@ROOT@(SORTBY,VUID,0)) Q:'IEN
.;
.I FILTER'="" D Q:VALUE'=FILTER
..S DATA=$G(^DIC(4.001,+IFN,0)),FILTERBY=$P(DATA,U,9)
..I FILTERBY="" S VALUE="ERROR" Q ;add error processing
..S IDX=$O(^DIC(4.001,+IFN,1,"B",FILTERBY,0))
..S DATA=$G(^DIC(4.001,+IFN,1,+IDX,0)),FIELD=$P(DATA,U,2)
..S TYP=$P(DATA,U,3),TYP=$$GET1^DIQ(771.4,(+TYP_","),.01)
..S VUID1=$P(DATA,U,13)
..S VALUE=$$VVAL(IFN,IEN_",",FIELD,$G(VUID1),TYP)
.;
.S ^TMP("HLA",$J,CNT)=$$MFE^XUMFMFE("MUP","",$$NOW^XLFDT,MFI_"@"_VUID)
.S CNT=CNT+1
.D ZRT
;
Q
;
ZRT ; data segments
;
Q:ERROR
;
S SEQ=0
F S SEQ=$O(^DIC(4.001,IFN,1,"ASEQ",SEQ)) Q:'SEQ D
.S IDX=$O(^DIC(4.001,IFN,1,"ASEQ",SEQ,0)) Q:'IDX
.S DATA=$G(^DIC(4.001,+IFN,1,+IDX,0)),NAME=$P(DATA,U)
.S TYP=$P(DATA,U,3),TYP=$$GET1^DIQ(771.4,(+TYP_","),.01)
.S FIELD=$P(DATA,U,2),SUBFILE=$P(DATA,U,4),MKEY=$P(DATA,U,6)
.S VUID1=$P(DATA,U,13),WP=$P(DATA,U,16)
.;
.I NAME="Status" D Q
..S:IFN'=757.33 ^TMP("HLA",$J,CNT)="ZRT"_HLFS_NAME_HLFS_(+$P($$GETSTAT^XTID(IFN,,IEN_","),U))
..S:IFN=757.33 ^TMP("HLA",$J,CNT)="ZRT"_HLFS_NAME_HLFS_$$STAT^XUMF502
..S CNT=CNT+1
.;
.I WP D WP Q
.;
.I SUBFILE D SUBFILE Q
.;
.S VALUE=$$VALUE(IFN,IEN_",",FIELD,VUID1,TYP) ;Q:VALUE=""
.;
.S ^TMP("HLA",$J,CNT)="ZRT"_HLFS_NAME_HLFS_VALUE
.S CNT=CNT+1
;
Q
;
SUBFILE ;
;
Q:ERROR
;
I NAME="Status" D Q
.S:IFN'=757.33 ^TMP("HLA",$J,CNT)="ZRT"_HLFS_NAME_HLFS_+$$GETSTAT^XTID(IFN,,IEN_",")
.S:IFN=757.33 ^TMP("HLA",$J,CNT)="ZRT"_HLFS_NAME_HLFS_$$STAT^XUMF502
.S CNT=CNT+1
;
N ROOT
;
S ROOT=$$ROOT^DILFD(SUBFILE,(","_IEN_","),1)
;
I MKEY="" S ERROR="1^null lookup column parameter for subfile: "_SUBFILE Q
;
S IEN1=0
F S IEN1=$O(@ROOT@(IEN1)) Q:'IEN1 D Q:ERROR
.;
.I $D(^DIC(4.001,IFN,1,IDX,1,"ASEQ1")) D SUBREC Q
.;
.S VALUE=$$VALUE(SUBFILE,IEN1_","_IEN_",",FIELD,VUID1,TYP) ;Q:VALUE=""
.;
.S ^TMP("HLA",$J,CNT)="ZRT"_HLFS_NAME_HLFS_VALUE
.S CNT=CNT+1
;
Q
;
SUBREC ; -- sub-records
;
Q:ERROR
;
N SEQ1,FIELD1,NAME1,VUID2,TYP2
;
S SEQ1=0
F S SEQ1=$O(^DIC(4.001,IFN,1,IDX,1,"ASEQ1",SEQ1)) Q:'SEQ1 D Q:ERROR
.S IDX1=$O(^DIC(4.001,IFN,1,IDX,1,"ASEQ1",SEQ1,0))
.;
.S NAME1=$P(^DIC(4.001,IFN,1,IDX,1,IDX1,0),U,2)
.I NAME1="" S ERROR="1^subrecord sequence name missing SUBFILE : "_SUBFILE Q
.S FIELD1=$P(^DIC(4.001,IFN,1,IDX,1,IDX1,0),U,3)
.I FIELD1="" S ERROR="1^subrecord sequence number missing SUBFILE : "_SUBFILE Q
.S VUID2=$P(^DIC(4.001,IFN,1,IDX,1,IDX1,0),U,4)
.S TYP2=$P(^DIC(4.001,IFN,1,IDX,1,IDX1,0),U,5)
.;
.S VALUE=$$VALUE(SUBFILE,IEN1_","_IEN_",",FIELD1,VUID2,TYP2) ;Q:VALUE=""
.;
.S ^TMP("HLA",$J,CNT)="ZRT"_HLFS_NAME1_HLFS_VALUE
.S CNT=CNT+1
;
Q
;
SEND ; -- send HL7 message
;
X:$D(^DIC(4.001,IFN,6))#2 ^DIC(4.001,IFN,6) ;p676 requested from the STS team - Randall Stewart and Jeff Udell
S HLP("PRIORITY")="I"
D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.HLRESLT)
;
; check for error
I ($P($G(HLRESLT),U,3)'="") D Q
.S ERROR=1_U_$P(HLRESLT,HLFS,3)_U_$P(HLRESLT,HLFS,2)_U_$P(HLRESLT,U)
;
; successful call, message ID returned
S ERROR="0^"_$P($G(HLRESLT),U,1)
;
Q
;
EXIT ; -- exit
;
D CLEAN^DILF
;
K ^TMP("HLA",$J)
;
Q
;
WP ;
;
N WP,I,J
;
S I=$$GET1^DIQ(IFN,IEN_",",FIELD,,"WP")
;
Q:'$D(WP)
;
S ^TMP("HLA",$J,CNT)="ZRT"_HLFS_NAME_HLFS_$G(WP(1))
;
S I=1,J=1
F S I=$O(WP(I)) Q:'I D
.S ^TMP("HLA",$J,CNT,J)=WP(I)
.S J=J+1
;
S CNT=CNT+1
;
Q
;
ESC(VALUE) ;
;
I VALUE["^" F Q:VALUE'["^" D
.S VALUE=$P(VALUE,"^")_"\F\"_$P(VALUE,"^",2,9999)
I VALUE["&" F Q:VALUE'["&" D
.S VALUE=$P(VALUE,"&")_"\T\"_$P(VALUE,"&",2,9999)
;
Q VALUE
;
VVAL(IFN,IENS,FIELD,VUID,TYP) ;
;
Q:IFN="" "" Q:FIELD="" "" Q:IENS="" ""
;
S:$G(TYP)="" TYP="ST"
S VUID=$S($G(VUID)'="":":99.99",1:"")
I IFN=757.33,$G(VUID)'="" S VUID=":5"
;
S VALUE=$$GET1^DIQ(IFN,IENS,FIELD_VUID) Q:VALUE="" ""
;S VALUE=$$GET1^DIQ(IFN,IENS,FIELD) Q:VALUE="" ""
S VALUE=$$DTYP^XUMFP(VALUE,TYP,HLCS,1)
S VALUE=$$ESC(VALUE)
;
;I IFN=757.32,FIELD=.02 Q $$MAPDEF
;
;Q $$VAL^XUMF0(IFN,FIELD,VUID,VALUE,IENS)
;
Q VALUE
;
VALUE(IFN,IENS,FIELD,VUID,TYP) ;
;
Q:IFN="" "" Q:FIELD="" "" Q:IENS="" ""
;
S:$G(TYP)="" TYP="ST"
;
S VALUE=$$GET1^DIQ(IFN,IENS,FIELD) Q:VALUE="" ""
S VALUE=$$DTYP^XUMFP(VALUE,TYP,HLCS,1)
S VALUE=$$ESC(VALUE)
;
I IFN=757.33,FIELD=.02 Q $$MAPDEF
;
Q VALUE
;
MAPDEF() ;
;
N X,Y
S X=$O(^LEX(757.32,"B",VALUE,0)) Q:'X 0
S Y=$G(^LEX(757.32,X,2))
Q $P(Y,U,3)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUMFQR 6601 printed Sep 23, 2025@19:47:18 Page 2
XUMFQR ;ISS/RAM - Master File Query Response ;02/10/2017
+1 ;;8.0;KERNEL;**407,502,676**;Jul 10, 1995;Build 8
+2 ;Per VHA Directive 10-92-142, this routine should not be modified
+3 ;
+4 QUIT
+5 ;
MAIN ; -- main
+1 ;
+2 NEW FIELD1,IDX,IDX1,NAME1,SUBFILE1,DATA1,IEN1,TYP1,MKEY,MKEY1,TYP,VUID,VUID1
+3 NEW MFI,SEQ,NAME,QRD,SEQ,SUBFILE,IEN,CNT,DATA,ERROR,SORTBY,FILTERBY,FILTER,ERRCNT
+4 ;
+5 DO INIT
DO PROCESS
DO MFR
DO SEND
DO EXIT
+6 ;
+7 QUIT
+8 ;
INIT ; -- initialize
+1 ;
+2 KILL ^TMP("HLA",$JOB)
+3 ;
+4 SET ERROR=0
SET CNT=1
SET ERRCNT=0
+5 ;
+6 SET HLFS=HL("FS")
SET HLCS=$EXTRACT(HL("ECH"))
SET HLSCS=$EXTRACT(HL("ECH"),4)
+7 ;
+8 QUIT
+9 ;
PROCESS ; -- pull message text
+1 ;
+2 FOR
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+3 if $PIECE(HLNODE,HLFS)=""
QUIT
+4 if "^MSH^MSA^QRD^"'[(U_$PIECE(HLNODE,HLFS)_U)
QUIT
+5 DO @($PIECE(HLNODE,HLFS))
End DoDot:1
+6 ;
+7 QUIT
+8 ;
MSH ; -- MSH segment
+1 ;
+2 QUIT
+3 ;
QRD ; -- QRD segment
+1 ;
+2 if ERROR
QUIT
+3 ;
+4 SET MFI=$PIECE(HLNODE,HLFS,10)
SET FILTER=$PIECE(MFI,HLCS,2)
SET MFI=$PIECE(MFI,HLCS)
+5 IF MFI=""
SET ERROR="1^MFI not resolved HLNODE: "_$TRANSLATE(HLNODE,HLFS,"#")
QUIT
+6 SET IFN=$ORDER(^DIC(4.001,"MFID",MFI,0))
+7 IF 'IFN
SET ERROR="1^IFN not resolved HLNODE: "_$TRANSLATE(HLNODE,HLFS,"#")
QUIT
+8 IF '$$VFILE^DILFD(IFN)
SET ERROR="1^invalid file number"
QUIT
+9 SET DATA=$GET(^DIC(4.001,+IFN,0))
SET SORTBY=$PIECE(DATA,U,8)
SET FILTERBY=$PIECE(DATA,U,9)
+10 ;
+11 ; -- get root of file
+12 SET ROOT=$$ROOT^DILFD(IFN,,1)
+13 ;
+14 SET QRD=HLNODE
+15 ;
+16 QUIT
+17 ;
MFR ; -- response
+1 ;
+2 DO MSA
DO QRD1
DO MFI
DO MFE
+3 ;
+4 QUIT
+5 ;
MSA ; -- Acknowledgement
+1 ;
+2 NEW X
+3 SET X="MSA"_HLFS_$SELECT(ERROR:"AE",1:"AA")_HLFS_HL("MID")_HLFS_$PIECE(ERROR,U,2)
+4 SET ^TMP("HLA",$JOB,CNT)=X
+5 SET CNT=CNT+1
+6 ;
+7 QUIT
+8 ;
QRD1 ; -- query definition segment
+1 ;
+2 if ERROR
QUIT
+3 ;
+4 SET ^TMP("HLA",$JOB,CNT)=$GET(QRD)
+5 SET CNT=CNT+1
+6 ;
+7 QUIT
+8 ;
MFI ; master file identifier segment
+1 ;
+2 if ERROR
QUIT
+3 ;
+4 SET ^TMP("HLA",$JOB,CNT)=$$MFI^XUMFMFI(MFI,"Standard Terminology","MUP",$$NOW^XLFDT,$$NOW^XLFDT,"NE")
+5 SET CNT=CNT+1
+6 ;
+7 QUIT
+8 ;
MFE ; master file entry segment
+1 ;
+2 if ERROR
QUIT
+3 ;
+4 SET VUID=0
FOR
SET VUID=$ORDER(@ROOT@($SELECT(SORTBY'="":SORTBY,1:"AMASTERVUID"),VUID))
if 'VUID
QUIT
Begin DoDot:1
+5 IF SORTBY=""
SET IEN=$ORDER(@ROOT@("AMASTERVUID",VUID,1,0))
if 'IEN
QUIT
+6 IF SORTBY'=""
SET IEN=$ORDER(@ROOT@(SORTBY,VUID,0))
if 'IEN
QUIT
+7 ;
+8 IF FILTER'=""
Begin DoDot:2
+9 SET DATA=$GET(^DIC(4.001,+IFN,0))
SET FILTERBY=$PIECE(DATA,U,9)
+10 ;add error processing
IF FILTERBY=""
SET VALUE="ERROR"
QUIT
+11 SET IDX=$ORDER(^DIC(4.001,+IFN,1,"B",FILTERBY,0))
+12 SET DATA=$GET(^DIC(4.001,+IFN,1,+IDX,0))
SET FIELD=$PIECE(DATA,U,2)
+13 SET TYP=$PIECE(DATA,U,3)
SET TYP=$$GET1^DIQ(771.4,(+TYP_","),.01)
+14 SET VUID1=$PIECE(DATA,U,13)
+15 SET VALUE=$$VVAL(IFN,IEN_",",FIELD,$GET(VUID1),TYP)
End DoDot:2
if VALUE'=FILTER
QUIT
+16 ;
+17 SET ^TMP("HLA",$JOB,CNT)=$$MFE^XUMFMFE("MUP","",$$NOW^XLFDT,MFI_"@"_VUID)
+18 SET CNT=CNT+1
+19 DO ZRT
End DoDot:1
if ERROR
QUIT
+20 ;
+21 QUIT
+22 ;
ZRT ; data segments
+1 ;
+2 if ERROR
QUIT
+3 ;
+4 SET SEQ=0
+5 FOR
SET SEQ=$ORDER(^DIC(4.001,IFN,1,"ASEQ",SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+6 SET IDX=$ORDER(^DIC(4.001,IFN,1,"ASEQ",SEQ,0))
if 'IDX
QUIT
+7 SET DATA=$GET(^DIC(4.001,+IFN,1,+IDX,0))
SET NAME=$PIECE(DATA,U)
+8 SET TYP=$PIECE(DATA,U,3)
SET TYP=$$GET1^DIQ(771.4,(+TYP_","),.01)
+9 SET FIELD=$PIECE(DATA,U,2)
SET SUBFILE=$PIECE(DATA,U,4)
SET MKEY=$PIECE(DATA,U,6)
+10 SET VUID1=$PIECE(DATA,U,13)
SET WP=$PIECE(DATA,U,16)
+11 ;
+12 IF NAME="Status"
Begin DoDot:2
+13 if IFN'=757.33
SET ^TMP("HLA",$JOB,CNT)="ZRT"_HLFS_NAME_HLFS_(+$PIECE($$GETSTAT^XTID(IFN,,IEN_","),U))
+14 if IFN=757.33
SET ^TMP("HLA",$JOB,CNT)="ZRT"_HLFS_NAME_HLFS_$$STAT^XUMF502
+15 SET CNT=CNT+1
End DoDot:2
QUIT
+16 ;
+17 IF WP
DO WP
QUIT
+18 ;
+19 IF SUBFILE
DO SUBFILE
QUIT
+20 ;
+21 ;Q:VALUE=""
SET VALUE=$$VALUE(IFN,IEN_",",FIELD,VUID1,TYP)
+22 ;
+23 SET ^TMP("HLA",$JOB,CNT)="ZRT"_HLFS_NAME_HLFS_VALUE
+24 SET CNT=CNT+1
End DoDot:1
+25 ;
+26 QUIT
+27 ;
SUBFILE ;
+1 ;
+2 if ERROR
QUIT
+3 ;
+4 IF NAME="Status"
Begin DoDot:1
+5 if IFN'=757.33
SET ^TMP("HLA",$JOB,CNT)="ZRT"_HLFS_NAME_HLFS_+$$GETSTAT^XTID(IFN,,IEN_",")
+6 if IFN=757.33
SET ^TMP("HLA",$JOB,CNT)="ZRT"_HLFS_NAME_HLFS_$$STAT^XUMF502
+7 SET CNT=CNT+1
End DoDot:1
QUIT
+8 ;
+9 NEW ROOT
+10 ;
+11 SET ROOT=$$ROOT^DILFD(SUBFILE,(","_IEN_","),1)
+12 ;
+13 IF MKEY=""
SET ERROR="1^null lookup column parameter for subfile: "_SUBFILE
QUIT
+14 ;
+15 SET IEN1=0
+16 FOR
SET IEN1=$ORDER(@ROOT@(IEN1))
if 'IEN1
QUIT
Begin DoDot:1
+17 ;
+18 IF $DATA(^DIC(4.001,IFN,1,IDX,1,"ASEQ1"))
DO SUBREC
QUIT
+19 ;
+20 ;Q:VALUE=""
SET VALUE=$$VALUE(SUBFILE,IEN1_","_IEN_",",FIELD,VUID1,TYP)
+21 ;
+22 SET ^TMP("HLA",$JOB,CNT)="ZRT"_HLFS_NAME_HLFS_VALUE
+23 SET CNT=CNT+1
End DoDot:1
if ERROR
QUIT
+24 ;
+25 QUIT
+26 ;
SUBREC ; -- sub-records
+1 ;
+2 if ERROR
QUIT
+3 ;
+4 NEW SEQ1,FIELD1,NAME1,VUID2,TYP2
+5 ;
+6 SET SEQ1=0
+7 FOR
SET SEQ1=$ORDER(^DIC(4.001,IFN,1,IDX,1,"ASEQ1",SEQ1))
if 'SEQ1
QUIT
Begin DoDot:1
+8 SET IDX1=$ORDER(^DIC(4.001,IFN,1,IDX,1,"ASEQ1",SEQ1,0))
+9 ;
+10 SET NAME1=$PIECE(^DIC(4.001,IFN,1,IDX,1,IDX1,0),U,2)
+11 IF NAME1=""
SET ERROR="1^subrecord sequence name missing SUBFILE : "_SUBFILE
QUIT
+12 SET FIELD1=$PIECE(^DIC(4.001,IFN,1,IDX,1,IDX1,0),U,3)
+13 IF FIELD1=""
SET ERROR="1^subrecord sequence number missing SUBFILE : "_SUBFILE
QUIT
+14 SET VUID2=$PIECE(^DIC(4.001,IFN,1,IDX,1,IDX1,0),U,4)
+15 SET TYP2=$PIECE(^DIC(4.001,IFN,1,IDX,1,IDX1,0),U,5)
+16 ;
+17 ;Q:VALUE=""
SET VALUE=$$VALUE(SUBFILE,IEN1_","_IEN_",",FIELD1,VUID2,TYP2)
+18 ;
+19 SET ^TMP("HLA",$JOB,CNT)="ZRT"_HLFS_NAME1_HLFS_VALUE
+20 SET CNT=CNT+1
End DoDot:1
if ERROR
QUIT
+21 ;
+22 QUIT
+23 ;
SEND ; -- send HL7 message
+1 ;
+2 ;p676 requested from the STS team - Randall Stewart and Jeff Udell
if $DATA(^DIC(4.001,IFN,6))#2
XECUTE ^DIC(4.001,IFN,6)
+3 SET HLP("PRIORITY")="I"
+4 DO GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.HLRESLT)
+5 ;
+6 ; check for error
+7 IF ($PIECE($GET(HLRESLT),U,3)'="")
Begin DoDot:1
+8 SET ERROR=1_U_$PIECE(HLRESLT,HLFS,3)_U_$PIECE(HLRESLT,HLFS,2)_U_$PIECE(HLRESLT,U)
End DoDot:1
QUIT
+9 ;
+10 ; successful call, message ID returned
+11 SET ERROR="0^"_$PIECE($GET(HLRESLT),U,1)
+12 ;
+13 QUIT
+14 ;
EXIT ; -- exit
+1 ;
+2 DO CLEAN^DILF
+3 ;
+4 KILL ^TMP("HLA",$JOB)
+5 ;
+6 QUIT
+7 ;
WP ;
+1 ;
+2 NEW WP,I,J
+3 ;
+4 SET I=$$GET1^DIQ(IFN,IEN_",",FIELD,,"WP")
+5 ;
+6 if '$DATA(WP)
QUIT
+7 ;
+8 SET ^TMP("HLA",$JOB,CNT)="ZRT"_HLFS_NAME_HLFS_$GET(WP(1))
+9 ;
+10 SET I=1
SET J=1
+11 FOR
SET I=$ORDER(WP(I))
if 'I
QUIT
Begin DoDot:1
+12 SET ^TMP("HLA",$JOB,CNT,J)=WP(I)
+13 SET J=J+1
End DoDot:1
+14 ;
+15 SET CNT=CNT+1
+16 ;
+17 QUIT
+18 ;
ESC(VALUE) ;
+1 ;
+2 IF VALUE["^"
FOR
if VALUE'["^"
QUIT
Begin DoDot:1
+3 SET VALUE=$PIECE(VALUE,"^")_"\F\"_$PIECE(VALUE,"^",2,9999)
End DoDot:1
+4 IF VALUE["&"
FOR
if VALUE'["&"
QUIT
Begin DoDot:1
+5 SET VALUE=$PIECE(VALUE,"&")_"\T\"_$PIECE(VALUE,"&",2,9999)
End DoDot:1
+6 ;
+7 QUIT VALUE
+8 ;
VVAL(IFN,IENS,FIELD,VUID,TYP) ;
+1 ;
+2 if IFN=""
QUIT ""
if FIELD=""
QUIT ""
if IENS=""
QUIT ""
+3 ;
+4 if $GET(TYP)=""
SET TYP="ST"
+5 SET VUID=$SELECT($GET(VUID)'="":":99.99",1:"")
+6 IF IFN=757.33
IF $GET(VUID)'=""
SET VUID=":5"
+7 ;
+8 SET VALUE=$$GET1^DIQ(IFN,IENS,FIELD_VUID)
if VALUE=""
QUIT ""
+9 ;S VALUE=$$GET1^DIQ(IFN,IENS,FIELD) Q:VALUE="" ""
+10 SET VALUE=$$DTYP^XUMFP(VALUE,TYP,HLCS,1)
+11 SET VALUE=$$ESC(VALUE)
+12 ;
+13 ;I IFN=757.32,FIELD=.02 Q $$MAPDEF
+14 ;
+15 ;Q $$VAL^XUMF0(IFN,FIELD,VUID,VALUE,IENS)
+16 ;
+17 QUIT VALUE
+18 ;
VALUE(IFN,IENS,FIELD,VUID,TYP) ;
+1 ;
+2 if IFN=""
QUIT ""
if FIELD=""
QUIT ""
if IENS=""
QUIT ""
+3 ;
+4 if $GET(TYP)=""
SET TYP="ST"
+5 ;
+6 SET VALUE=$$GET1^DIQ(IFN,IENS,FIELD)
if VALUE=""
QUIT ""
+7 SET VALUE=$$DTYP^XUMFP(VALUE,TYP,HLCS,1)
+8 SET VALUE=$$ESC(VALUE)
+9 ;
+10 IF IFN=757.33
IF FIELD=.02
QUIT $$MAPDEF
+11 ;
+12 QUIT VALUE
+13 ;
MAPDEF() ;
+1 ;
+2 NEW X,Y
+3 SET X=$ORDER(^LEX(757.32,"B",VALUE,0))
if 'X
QUIT 0
+4 SET Y=$GET(^LEX(757.32,X,2))
+5 QUIT $PIECE(Y,U,3)
+6 ;
