Routine: XUMFXP1

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

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

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       ;

XUMFXP1.m