XUMFPFT ;CIOFO-SF/RAM - Master File Param FACILITY TYPE ;06/28/00
;;8.0;KERNEL;**206,217**;Jul 10, 1995
;
; This routine sets up the parameters required by the FACILITY TYPE
; (#4) file for the Master File server mechanism.
;
; ** This routine is not a supported interface -- use XUMFP **
;
; See XUMFP for parameter list documentation
;
N PKV,PROTOCOL,HLFS,HLCS,RT,RF
;
S PARAM("PRE")="PRE^XUMFPFT"
S PARAM("POST")="POST^XUMFPFT"
;
I $O(HL(""))="" D
.S:UPDATE PROTOCOL=$O(^ORD(101,"B","XUMF MFN",0))
.S:QUERY PROTOCOL=$O(^ORD(101,"B","XUMF MFQ",0))
.S:'PROTOCOL ERROR="1^invalid protocol" Q:ERROR
.S ^TMP("XUMF MFS",$J,"PARAM","PROTOCOL")=PROTOCOL
.D INIT^HLFNC2(PROTOCOL,.HL)
;
I $O(HL(""))="" S ERROR="1^"_$P(HL,U,2) Q
S HLFS=HL("FS"),HLCS=$E(HL("ECH"))
;
I QUERY D QRD
;
; MFI -- Master File Identification Segment
S ^TMP("XUMF MFS",$J,"PARAM","MFI")="Z4T" ;Master File Identifier
S ^TMP("XUMF MFS",$J,"PARAM","MFAI")="" ;Application Identifier
S ^TMP("XUMF MFS",$J,"PARAM","FLEC")="UPD" ;File-Level Event Code
S ^TMP("XUMF MFS",$J,"PARAM","ENDT")="" ;Entered Data/Time
S ^TMP("XUMF MFS",$J,"PARAM","MFIEDT")="" ;Effective Date/Time
S ^TMP("XUMF MFS",$J,"PARAM","RLC")="NE" ;Response Level Code
;
; MFE -- Master File Entry
I $G(^TMP("XUMF MFS",$J,"PARAM","RLEC"))="" D ;Record-Level Event Code
.S ^TMP("XUMF MFS",$J,"PARAM","RLEC")="MUP"
S ^TMP("XUMF MFS",$J,"PARAM","MFNCID")="" ;MFN Control ID
I $G(^TMP("XUMF MFS",$J,"PARAM","MFEEDT"))="" D ;Effective Date/Time
.S ^TMP("XUMF MFS",$J,"PARAM","MFEEDT")=$$HLDATE^HLFNC($$NOW^XLFDT)
;
SEG ; -- ZFT segment
;
I IEN D
.S PKV=$P($G(^DIC(4.1,+IEN,0)),U)_HLCS_"FACILITY TYPE"_HLCS_"B"
.S ^TMP("XUMF MFS",$J,"PARAM","PKV")=PKV ; Primary Key Value
I NEW D
.S PKV="NEW"_HLCS_"FACILITY TYPE"_HLCS_"B"
.S ^TMP("XUMF MFS",$J,"PARAM","PKV")=PKV ; Primary Key Value
;
; ZFT -- VA Specific VHA Facility Type Segment sequence
S ^TMP("XUMF MFS",$J,"PARAM","SEGMENT")="ZFT"
S ^TMP("XUMF MFS",$J,"PARAM","SEG","ZFT","SEQ",1,.01)="ST" ;name
S ^TMP("XUMF MFS",$J,"PARAM","SEG","ZFT","SEQ",2,1)="ST" ;full name
S ^TMP("XUMF MFS",$J,"PARAM","SEG","ZFT","SEQ",3,2)="ST" ;title
S ^TMP("XUMF MFS",$J,"PARAM","SEG","ZFT","SEQ",4,3)="ST" ;status
;
Q:'GROUP
Q:$G(HL("MTN"))="MFR"
;
GROUP ; -- query group
;
S IEN=0
F S IEN=$O(^TMP("XUMF MFS",$J,"PARAM","IEN",IEN)) Q:'IEN D
.S PKV=$P(^DIC(4.1,IEN,0),U)_HLCS_"FACILITY TYPE"_HLCS_"B"
.S ^TMP("XUMF MFS",$J,"PARAM",IEN,"PKV")=PKV
;
Q
;
QRD ; -- query definition segment
;
;Query Date/Time
I '$D(^TMP("XUMF MFS",$J,"PARAM","QDT")) D
.S ^TMP("XUMF MFS",$J,"PARAM","QDT")=$$HLDATE^HLFNC($$NOW^XLFDT)
;
;Query Format Code
I '$D(^TMP("XUMF MFS",$J,"PARAM","QFC")) D
.S ^TMP("XUMF MFS",$J,"PARAM","QFC")="R"
;
;Query Priority
I '$D(^TMP("XUMF MFS",$J,"PARAM","QP")) D
.S ^TMP("XUMF MFS",$J,"PARAM","QP")="I"
;
;Query ID
I '$D(^TMP("XUMF MFS",$J,"PARAM","QID")) D
.S ^TMP("XUMF MFS",$J,"PARAM","QID")="Z4T "_$S(ARRAY:"ARRAY",1:"FILE")
;
;Deferred Response Type (optional)
I '$D(^TMP("XUMF MFS",$J,"PARAM","DRT")) D
.S ^TMP("XUMF MFS",$J,"PARAM","DRT")=""
;
;Deferred Response Date/Time (optional)
I '$D(^TMP("XUMF MFS",$J,"PARAM","DRDT")) D
.S ^TMP("XUMF MFS",$J,"PARAM","DRDT")=""
;
;Quantity Limited Request
I '$D(^TMP("XUMF MFS",$J,"PARAM","QLR")) D
.S ^TMP("XUMF MFS",$J,"PARAM","QLR")="RD"_HLCS_999
;
;Who Subject Filter - sta#, D x-ref, assigning facility
I '$D(^TMP("XUMF MFS",$J,"PARAM","WHO")) D
.N X S X=$S(ALL:"ALL",IEN:$P($G(^DIC(4.1,+IEN,0)),U),1:"IEN ARRAY")
.S $P(X,HLCS,9,10)="B"_HLCS_"VA"
.S ^TMP("XUMF MFS",$J,"PARAM","WHO")=X
;
;What Subject Filter
I '$D(^TMP("XUMF MFS",$J,"PARAM","WHAT")) D
.S ^TMP("XUMF MFS",$J,"PARAM","WHAT")="4.1"_HLCS_"IFN"_HLCS_"VA FM"
;
;What Department Data Code
I '$D(^TMP("XUMF MFS",$J,"PARAM","WDDC")) D
.N X S X="INFRASTRUCTURE"_HLCS_"INFORMATION INFRASTRUCTURE"
.S X=X_HLCS_"VA TS"
.S ^TMP("XUMF MFS",$J,"PARAM","WDDC")=X
;
;What Data Code Value Qual (optional)
I '$D(^TMP("XUMF MFS",$J,"PARAM","WDCVQ")) D
.S ^TMP("XUMF MFS",$J,"PARAM","WDCVQ")=""
;
;Query Results Level (optional)
I '$D(^TMP("XUMF MFS",$J,"PARAM","QRL")) D
.S ^TMP("XUMF MFS",$J,"PARAM","QRL")=""
;
Q
;
PRE ; -- pre-update record
;
Q
;
POST ; -- post-update record
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUMFPFT 4440 printed Nov 22, 2024@17:21:09 Page 2
XUMFPFT ;CIOFO-SF/RAM - Master File Param FACILITY TYPE ;06/28/00
+1 ;;8.0;KERNEL;**206,217**;Jul 10, 1995
+2 ;
+3 ; This routine sets up the parameters required by the FACILITY TYPE
+4 ; (#4) file for the Master File server mechanism.
+5 ;
+6 ; ** This routine is not a supported interface -- use XUMFP **
+7 ;
+8 ; See XUMFP for parameter list documentation
+9 ;
+10 NEW PKV,PROTOCOL,HLFS,HLCS,RT,RF
+11 ;
+12 SET PARAM("PRE")="PRE^XUMFPFT"
+13 SET PARAM("POST")="POST^XUMFPFT"
+14 ;
+15 IF $ORDER(HL(""))=""
Begin DoDot:1
+16 if UPDATE
SET PROTOCOL=$ORDER(^ORD(101,"B","XUMF MFN",0))
+17 if QUERY
SET PROTOCOL=$ORDER(^ORD(101,"B","XUMF MFQ",0))
+18 if 'PROTOCOL
SET ERROR="1^invalid protocol"
if ERROR
QUIT
+19 SET ^TMP("XUMF MFS",$JOB,"PARAM","PROTOCOL")=PROTOCOL
+20 DO INIT^HLFNC2(PROTOCOL,.HL)
End DoDot:1
+21 ;
+22 IF $ORDER(HL(""))=""
SET ERROR="1^"_$PIECE(HL,U,2)
QUIT
+23 SET HLFS=HL("FS")
SET HLCS=$EXTRACT(HL("ECH"))
+24 ;
+25 IF QUERY
DO QRD
+26 ;
+27 ; MFI -- Master File Identification Segment
+28 ;Master File Identifier
SET ^TMP("XUMF MFS",$JOB,"PARAM","MFI")="Z4T"
+29 ;Application Identifier
SET ^TMP("XUMF MFS",$JOB,"PARAM","MFAI")=""
+30 ;File-Level Event Code
SET ^TMP("XUMF MFS",$JOB,"PARAM","FLEC")="UPD"
+31 ;Entered Data/Time
SET ^TMP("XUMF MFS",$JOB,"PARAM","ENDT")=""
+32 ;Effective Date/Time
SET ^TMP("XUMF MFS",$JOB,"PARAM","MFIEDT")=""
+33 ;Response Level Code
SET ^TMP("XUMF MFS",$JOB,"PARAM","RLC")="NE"
+34 ;
+35 ; MFE -- Master File Entry
+36 ;Record-Level Event Code
IF $GET(^TMP("XUMF MFS",$JOB,"PARAM","RLEC"))=""
Begin DoDot:1
+37 SET ^TMP("XUMF MFS",$JOB,"PARAM","RLEC")="MUP"
End DoDot:1
+38 ;MFN Control ID
SET ^TMP("XUMF MFS",$JOB,"PARAM","MFNCID")=""
+39 ;Effective Date/Time
IF $GET(^TMP("XUMF MFS",$JOB,"PARAM","MFEEDT"))=""
Begin DoDot:1
+40 SET ^TMP("XUMF MFS",$JOB,"PARAM","MFEEDT")=$$HLDATE^HLFNC($$NOW^XLFDT)
End DoDot:1
+41 ;
SEG ; -- ZFT segment
+1 ;
+2 IF IEN
Begin DoDot:1
+3 SET PKV=$PIECE($GET(^DIC(4.1,+IEN,0)),U)_HLCS_"FACILITY TYPE"_HLCS_"B"
+4 ; Primary Key Value
SET ^TMP("XUMF MFS",$JOB,"PARAM","PKV")=PKV
End DoDot:1
+5 IF NEW
Begin DoDot:1
+6 SET PKV="NEW"_HLCS_"FACILITY TYPE"_HLCS_"B"
+7 ; Primary Key Value
SET ^TMP("XUMF MFS",$JOB,"PARAM","PKV")=PKV
End DoDot:1
+8 ;
+9 ; ZFT -- VA Specific VHA Facility Type Segment sequence
+10 SET ^TMP("XUMF MFS",$JOB,"PARAM","SEGMENT")="ZFT"
+11 ;name
SET ^TMP("XUMF MFS",$JOB,"PARAM","SEG","ZFT","SEQ",1,.01)="ST"
+12 ;full name
SET ^TMP("XUMF MFS",$JOB,"PARAM","SEG","ZFT","SEQ",2,1)="ST"
+13 ;title
SET ^TMP("XUMF MFS",$JOB,"PARAM","SEG","ZFT","SEQ",3,2)="ST"
+14 ;status
SET ^TMP("XUMF MFS",$JOB,"PARAM","SEG","ZFT","SEQ",4,3)="ST"
+15 ;
+16 if 'GROUP
QUIT
+17 if $GET(HL("MTN"))="MFR"
QUIT
+18 ;
GROUP ; -- query group
+1 ;
+2 SET IEN=0
+3 FOR
SET IEN=$ORDER(^TMP("XUMF MFS",$JOB,"PARAM","IEN",IEN))
if 'IEN
QUIT
Begin DoDot:1
+4 SET PKV=$PIECE(^DIC(4.1,IEN,0),U)_HLCS_"FACILITY TYPE"_HLCS_"B"
+5 SET ^TMP("XUMF MFS",$JOB,"PARAM",IEN,"PKV")=PKV
End DoDot:1
+6 ;
+7 QUIT
+8 ;
QRD ; -- query definition segment
+1 ;
+2 ;Query Date/Time
+3 IF '$DATA(^TMP("XUMF MFS",$JOB,"PARAM","QDT"))
Begin DoDot:1
+4 SET ^TMP("XUMF MFS",$JOB,"PARAM","QDT")=$$HLDATE^HLFNC($$NOW^XLFDT)
End DoDot:1
+5 ;
+6 ;Query Format Code
+7 IF '$DATA(^TMP("XUMF MFS",$JOB,"PARAM","QFC"))
Begin DoDot:1
+8 SET ^TMP("XUMF MFS",$JOB,"PARAM","QFC")="R"
End DoDot:1
+9 ;
+10 ;Query Priority
+11 IF '$DATA(^TMP("XUMF MFS",$JOB,"PARAM","QP"))
Begin DoDot:1
+12 SET ^TMP("XUMF MFS",$JOB,"PARAM","QP")="I"
End DoDot:1
+13 ;
+14 ;Query ID
+15 IF '$DATA(^TMP("XUMF MFS",$JOB,"PARAM","QID"))
Begin DoDot:1
+16 SET ^TMP("XUMF MFS",$JOB,"PARAM","QID")="Z4T "_$SELECT(ARRAY:"ARRAY",1:"FILE")
End DoDot:1
+17 ;
+18 ;Deferred Response Type (optional)
+19 IF '$DATA(^TMP("XUMF MFS",$JOB,"PARAM","DRT"))
Begin DoDot:1
+20 SET ^TMP("XUMF MFS",$JOB,"PARAM","DRT")=""
End DoDot:1
+21 ;
+22 ;Deferred Response Date/Time (optional)
+23 IF '$DATA(^TMP("XUMF MFS",$JOB,"PARAM","DRDT"))
Begin DoDot:1
+24 SET ^TMP("XUMF MFS",$JOB,"PARAM","DRDT")=""
End DoDot:1
+25 ;
+26 ;Quantity Limited Request
+27 IF '$DATA(^TMP("XUMF MFS",$JOB,"PARAM","QLR"))
Begin DoDot:1
+28 SET ^TMP("XUMF MFS",$JOB,"PARAM","QLR")="RD"_HLCS_999
End DoDot:1
+29 ;
+30 ;Who Subject Filter - sta#, D x-ref, assigning facility
+31 IF '$DATA(^TMP("XUMF MFS",$JOB,"PARAM","WHO"))
Begin DoDot:1
+32 NEW X
SET X=$SELECT(ALL:"ALL",IEN:$PIECE($GET(^DIC(4.1,+IEN,0)),U),1:"IEN ARRAY")
+33 SET $PIECE(X,HLCS,9,10)="B"_HLCS_"VA"
+34 SET ^TMP("XUMF MFS",$JOB,"PARAM","WHO")=X
End DoDot:1
+35 ;
+36 ;What Subject Filter
+37 IF '$DATA(^TMP("XUMF MFS",$JOB,"PARAM","WHAT"))
Begin DoDot:1
+38 SET ^TMP("XUMF MFS",$JOB,"PARAM","WHAT")="4.1"_HLCS_"IFN"_HLCS_"VA FM"
End DoDot:1
+39 ;
+40 ;What Department Data Code
+41 IF '$DATA(^TMP("XUMF MFS",$JOB,"PARAM","WDDC"))
Begin DoDot:1
+42 NEW X
SET X="INFRASTRUCTURE"_HLCS_"INFORMATION INFRASTRUCTURE"
+43 SET X=X_HLCS_"VA TS"
+44 SET ^TMP("XUMF MFS",$JOB,"PARAM","WDDC")=X
End DoDot:1
+45 ;
+46 ;What Data Code Value Qual (optional)
+47 IF '$DATA(^TMP("XUMF MFS",$JOB,"PARAM","WDCVQ"))
Begin DoDot:1
+48 SET ^TMP("XUMF MFS",$JOB,"PARAM","WDCVQ")=""
End DoDot:1
+49 ;
+50 ;Query Results Level (optional)
+51 IF '$DATA(^TMP("XUMF MFS",$JOB,"PARAM","QRL"))
Begin DoDot:1
+52 SET ^TMP("XUMF MFS",$JOB,"PARAM","QRL")=""
End DoDot:1
+53 ;
+54 QUIT
+55 ;
PRE ; -- pre-update record
+1 ;
+2 QUIT
+3 ;
POST ; -- post-update record
+1 ;
+2 QUIT
+3 ;
