XUMFXP1 ;ISS/RAM - MFS parameters ;06/28/00
;;8.0;KERNEL;**299**;Jul 10, 1995
;
;
; This routine sets up the parameters required by the
; Master File server mechanism.
;
; ** This routine is not a supported interface -- use XUMFXP **
;
; See XUMFXP for parameter list documentation
;
Q
;
MAIN ; -- main
;
N PKV,HLFS,HLCS,RT,RF,SEQ,PRE,POST,LKUP,RDF,NUM,HLREP,IDX,XXX,YYY,X,Y
;
I 'PROTOCOL D
.;S:UPDATE PROTOCOL=$$FIND1^DIC(101,,"B","DS Pub Man~~L")
.S:UPDATE PROTOCOL=$$FIND1^DIC(101,,"B","XUMFX SERVER")
.S:QUERY PROTOCOL=$$FIND1^DIC(101,,"B","XUMF MFQ")
S:'PROTOCOL ERROR="1^invalid protocol" Q:ERROR
S ^TMP("XUMF MFS",$J,"PARAM","PROTOCOL")=PROTOCOL
;
I $O(HL(""))="" D
.D INIT^HLFNC2(PROTOCOL,.HL)
I $O(HL(""))="" S ERROR="1^"_$P(HL,U,2) Q
S HLFS=HL("FS"),HLCS=$E(HL("ECH")),HLREP=$E(HL("ECH"),2)
;
Q:$G(MFK)
;
I QUERY D QRD^XUMFXP2
;
; MFI -- Master File Identification
;
;Master File Identifier
;S ^TMP("XUMF MFS",$J,"PARAM","MFI")=$P($G(^DIC(4.001,+IFN,0)),U,3)
S ^TMP("XUMF MFS",$J,"PARAM","MFI")=+IFN
;Application Identifier
S ^TMP("XUMF MFS",$J,"PARAM","MFAI")=$G(^TMP("XUMF MFS",$J,"PARAM","MFAI"))
;File-Level Event Code
S ^TMP("XUMF MFS",$J,"PARAM","FLEC")="UPD"
;Entered Data/Time
S ^TMP("XUMF MFS",$J,"PARAM","ENDT")=""
;Effective Date/Time
S ^TMP("XUMF MFS",$J,"PARAM","MFIEDT")=""
;Response Level Code
S ^TMP("XUMF MFS",$J,"PARAM","RLC")="NE"
;
; MFE -- Master File Entry
;
;Record-Level Event Code
I $G(^TMP("XUMF MFS",$J,"PARAM","RLEC"))="" D
.S ^TMP("XUMF MFS",$J,"PARAM","RLEC")="MUP"
;MFN Control ID
S ^TMP("XUMF MFS",$J,"PARAM","MFNCID")=""
;Effective Date/Time
I $G(^TMP("XUMF MFS",$J,"PARAM","MFEEDT"))="" D
.S ^TMP("XUMF MFS",$J,"PARAM","MFEEDT")=$$HLDATE^HLFNC($$NOW^XLFDT)
;
SEG ; -- data segment
;
;FOR MULTIPLE FIELDS
;
; MKEY is defined only when .01 is not passed in HL7 segment
; but is some constant string (like VISN in INSTITUTION assoc mult).
; MKEY and MULT evaluate FALSE.
;
; MULT is set to field number # for SEQ. SEQ=.01 set to itself.
; MULT set to .01 field #. MULT is TRUE. MKEY undefined.
;
I IEN D
.S PKV=$$PKV^XUMFX(IFN,IEN,HLCS)
.S ^TMP("XUMF MFS",$J,"PARAM","PKV")=PKV
I NEW D
.S PKV=$$PKV^XUMFX(IFN,"NEW",HLCS)
.S ^TMP("XUMF MFS",$J,"PARAM","PKV")=PKV
;
S (IDX,SEQ,NUM,CNT)=0,RDF(0)=""
F S IDX=$O(^DIC(4.001,IFN,1,IDX)) Q:'IDX D
.S Y=$G(^DIC(4.001,+IFN,1,IDX,0))
.;
.N FLD,TYP,SUBFILE,COLUMN,WIDTH
.S COLUMN=$P(Y,U),WIDTH=$P(Y,U,9),NUM=NUM+1,SEQ=SEQ+1
.S FLD=$P(Y,U,2),SUBFILE=$P(Y,U,4),LKUP=$P(Y,U,7)
.S TYP=$P(Y,U,3),TYP=$$GET1^DIQ(771.4,(+TYP_","),.01)
.S YYY(COLUMN,SEQ)=""
.;
.I $L(RDF(CNT)_(COLUMN_HLCS_TYP_HLCS_WIDTH_HLREP))>200 D
..S CNT=CNT+1,RDF(CNT)=""
.S RDF(CNT)=RDF(CNT)_COLUMN_HLCS_TYP_HLCS_WIDTH_HLREP
.;
.I 'SUBFILE D Q
..S ^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,FLD)=TYP_U_LKUP
.;
.; -- multiple
.;
.I $P(Y,U,6)'="" D ;.01 is a field
..;S ^TMP("XUMF MFS",$J,"PARAM","MULT",SEQ)=$P(Y,U,6)
..S XXX(SEQ)=$P(Y,U,6)
.I $P(Y,U,6)="" D ;.01 is lkup on MKEY literal
..S ^TMP("XUMF MFS",$J,"PARAM","MULT",SEQ)=""
..S ^TMP("XUMF MFS",$J,"PARAM","MKEY",SEQ)=$P(Y,U,5)
.;
.N LKUP,FUNC
.S LKUP=$P(Y,U,7),FUNC=$P(Y,U,8)
.S ^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"FILE")=SUBFILE
.S ^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"FIELD")=FLD
.S ^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"DTYP")=TYP
.S ^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"LKUP")=LKUP
.Q:'IEN
.I 'FUNC,FUNC'="" D
..I FUNC'["(" S FUNC="$$"_FUNC_"^XUMFF" Q
..S FUNC="$$"_$P(FUNC,"(")_"^XUMFF("_$P(FUNC,"(",2)
.S X="S X="_FUNC X:X["$$" X
.Q:'X
.S ^TMP("XUMF MFS",$J,"PARAM","IENS",SEQ)=X_","_IEN_","
;
S SEQ=0
F S SEQ=$O(XXX(SEQ)) Q:'SEQ D
.S X=XXX(SEQ),Y=$O(YYY(X,0))
.S ^TMP("XUMF MFS",$J,"PARAM","MULT",SEQ)=Y
;
S RDF="RDF"_HLFS_NUM_HLFS_RDF(0) K RDF(0)
M ^TMP("XUMF MFS",$J,"PARAM","RDF")=RDF
;
GROUP ; -- query group
;
D GROUP^XUMFXP2
;
Q
;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUMFXP1 4021 printed Apr 09, 2024@21:16:31 Page 2
XUMFXP1 ;ISS/RAM - MFS parameters ;06/28/00
+1 ;;8.0;KERNEL;**299**;Jul 10, 1995
+2 ;
+3 ;
+4 ; This routine sets up the parameters required by the
+5 ; Master File server mechanism.
+6 ;
+7 ; ** This routine is not a supported interface -- use XUMFXP **
+8 ;
+9 ; See XUMFXP for parameter list documentation
+10 ;
+11 QUIT
+12 ;
MAIN ; -- main
+1 ;
+2 NEW PKV,HLFS,HLCS,RT,RF,SEQ,PRE,POST,LKUP,RDF,NUM,HLREP,IDX,XXX,YYY,X,Y
+3 ;
+4 IF 'PROTOCOL
Begin DoDot:1
+5 ;S:UPDATE PROTOCOL=$$FIND1^DIC(101,,"B","DS Pub Man~~L")
+6 if UPDATE
SET PROTOCOL=$$FIND1^DIC(101,,"B","XUMFX SERVER")
+7 if QUERY
SET PROTOCOL=$$FIND1^DIC(101,,"B","XUMF MFQ")
End DoDot:1
+8 if 'PROTOCOL
SET ERROR="1^invalid protocol"
if ERROR
QUIT
+9 SET ^TMP("XUMF MFS",$JOB,"PARAM","PROTOCOL")=PROTOCOL
+10 ;
+11 IF $ORDER(HL(""))=""
Begin DoDot:1
+12 DO INIT^HLFNC2(PROTOCOL,.HL)
End DoDot:1
+13 IF $ORDER(HL(""))=""
SET ERROR="1^"_$PIECE(HL,U,2)
QUIT
+14 SET HLFS=HL("FS")
SET HLCS=$EXTRACT(HL("ECH"))
SET HLREP=$EXTRACT(HL("ECH"),2)
+15 ;
+16 if $GET(MFK)
QUIT
+17 ;
+18 IF QUERY
DO QRD^XUMFXP2
+19 ;
+20 ; MFI -- Master File Identification
+21 ;
+22 ;Master File Identifier
+23 ;S ^TMP("XUMF MFS",$J,"PARAM","MFI")=$P($G(^DIC(4.001,+IFN,0)),U,3)
+24 SET ^TMP("XUMF MFS",$JOB,"PARAM","MFI")=+IFN
+25 ;Application Identifier
+26 SET ^TMP("XUMF MFS",$JOB,"PARAM","MFAI")=$GET(^TMP("XUMF MFS",$JOB,"PARAM","MFAI"))
+27 ;File-Level Event Code
+28 SET ^TMP("XUMF MFS",$JOB,"PARAM","FLEC")="UPD"
+29 ;Entered Data/Time
+30 SET ^TMP("XUMF MFS",$JOB,"PARAM","ENDT")=""
+31 ;Effective Date/Time
+32 SET ^TMP("XUMF MFS",$JOB,"PARAM","MFIEDT")=""
+33 ;Response Level Code
+34 SET ^TMP("XUMF MFS",$JOB,"PARAM","RLC")="NE"
+35 ;
+36 ; MFE -- Master File Entry
+37 ;
+38 ;Record-Level Event Code
+39 IF $GET(^TMP("XUMF MFS",$JOB,"PARAM","RLEC"))=""
Begin DoDot:1
+40 SET ^TMP("XUMF MFS",$JOB,"PARAM","RLEC")="MUP"
End DoDot:1
+41 ;MFN Control ID
+42 SET ^TMP("XUMF MFS",$JOB,"PARAM","MFNCID")=""
+43 ;Effective Date/Time
+44 IF $GET(^TMP("XUMF MFS",$JOB,"PARAM","MFEEDT"))=""
Begin DoDot:1
+45 SET ^TMP("XUMF MFS",$JOB,"PARAM","MFEEDT")=$$HLDATE^HLFNC($$NOW^XLFDT)
End DoDot:1
+46 ;
SEG ; -- data segment
+1 ;
+2 ;FOR MULTIPLE FIELDS
+3 ;
+4 ; MKEY is defined only when .01 is not passed in HL7 segment
+5 ; but is some constant string (like VISN in INSTITUTION assoc mult).
+6 ; MKEY and MULT evaluate FALSE.
+7 ;
+8 ; MULT is set to field number # for SEQ. SEQ=.01 set to itself.
+9 ; MULT set to .01 field #. MULT is TRUE. MKEY undefined.
+10 ;
+11 IF IEN
Begin DoDot:1
+12 SET PKV=$$PKV^XUMFX(IFN,IEN,HLCS)
+13 SET ^TMP("XUMF MFS",$JOB,"PARAM","PKV")=PKV
End DoDot:1
+14 IF NEW
Begin DoDot:1
+15 SET PKV=$$PKV^XUMFX(IFN,"NEW",HLCS)
+16 SET ^TMP("XUMF MFS",$JOB,"PARAM","PKV")=PKV
End DoDot:1
+17 ;
+18 SET (IDX,SEQ,NUM,CNT)=0
SET RDF(0)=""
+19 FOR
SET IDX=$ORDER(^DIC(4.001,IFN,1,IDX))
if 'IDX
QUIT
Begin DoDot:1
+20 SET Y=$GET(^DIC(4.001,+IFN,1,IDX,0))
+21 ;
+22 NEW FLD,TYP,SUBFILE,COLUMN,WIDTH
+23 SET COLUMN=$PIECE(Y,U)
SET WIDTH=$PIECE(Y,U,9)
SET NUM=NUM+1
SET SEQ=SEQ+1
+24 SET FLD=$PIECE(Y,U,2)
SET SUBFILE=$PIECE(Y,U,4)
SET LKUP=$PIECE(Y,U,7)
+25 SET TYP=$PIECE(Y,U,3)
SET TYP=$$GET1^DIQ(771.4,(+TYP_","),.01)
+26 SET YYY(COLUMN,SEQ)=""
+27 ;
+28 IF $LENGTH(RDF(CNT)_(COLUMN_HLCS_TYP_HLCS_WIDTH_HLREP))>200
Begin DoDot:2
+29 SET CNT=CNT+1
SET RDF(CNT)=""
End DoDot:2
+30 SET RDF(CNT)=RDF(CNT)_COLUMN_HLCS_TYP_HLCS_WIDTH_HLREP
+31 ;
+32 IF 'SUBFILE
Begin DoDot:2
+33 SET ^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,FLD)=TYP_U_LKUP
End DoDot:2
QUIT
+34 ;
+35 ; -- multiple
+36 ;
+37 ;.01 is a field
IF $PIECE(Y,U,6)'=""
Begin DoDot:2
+38 ;S ^TMP("XUMF MFS",$J,"PARAM","MULT",SEQ)=$P(Y,U,6)
+39 SET XXX(SEQ)=$PIECE(Y,U,6)
End DoDot:2
+40 ;.01 is lkup on MKEY literal
IF $PIECE(Y,U,6)=""
Begin DoDot:2
+41 SET ^TMP("XUMF MFS",$JOB,"PARAM","MULT",SEQ)=""
+42 SET ^TMP("XUMF MFS",$JOB,"PARAM","MKEY",SEQ)=$PIECE(Y,U,5)
End DoDot:2
+43 ;
+44 NEW LKUP,FUNC
+45 SET LKUP=$PIECE(Y,U,7)
SET FUNC=$PIECE(Y,U,8)
+46 SET ^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"FILE")=SUBFILE
+47 SET ^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"FIELD")=FLD
+48 SET ^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"DTYP")=TYP
+49 SET ^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"LKUP")=LKUP
+50 if 'IEN
QUIT
+51 IF 'FUNC
IF FUNC'=""
Begin DoDot:2
+52 IF FUNC'["("
SET FUNC="$$"_FUNC_"^XUMFF"
QUIT
+53 SET FUNC="$$"_$PIECE(FUNC,"(")_"^XUMFF("_$PIECE(FUNC,"(",2)
End DoDot:2
+54 SET X="S X="_FUNC
if X["$$"
XECUTE X
+55 if 'X
QUIT
+56 SET ^TMP("XUMF MFS",$JOB,"PARAM","IENS",SEQ)=X_","_IEN_","
End DoDot:1
+57 ;
+58 SET SEQ=0
+59 FOR
SET SEQ=$ORDER(XXX(SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+60 SET X=XXX(SEQ)
SET Y=$ORDER(YYY(X,0))
+61 SET ^TMP("XUMF MFS",$JOB,"PARAM","MULT",SEQ)=Y
End DoDot:1
+62 ;
+63 SET RDF="RDF"_HLFS_NUM_HLFS_RDF(0)
KILL RDF(0)
+64 MERGE ^TMP("XUMF MFS",$JOB,"PARAM","RDF")=RDF
+65 ;
GROUP ; -- query group
+1 ;
+2 DO GROUP^XUMFXP2
+3 ;
+4 QUIT
+5 ;
+6 ;
