XUMF04Q ;BP/RAM - INSTITUTION QUERY ;06/28/00
;;8.0;KERNEL;**549,678**;Jul 10, 1995;Build 13
;;Per VA Directive 6402, this routine should not be modified
Q
;
EN ; -- QUERY and PROCESS RESPONSE
;
Q:$$KSP^XUPARAM("INST")=12000
Q:$P($$PARAM^HLCS2,U,3)="T"
;
N XUMFCD
;
M ^TMP("XUMF 04",$$NOW^XLFDT,$J,4)=^DIC(4)
;
W !!!,"GET FACILITY TYPE",!!!
; load facility type
D LOAD^XUMF(4.1)
;
W !!!,"GET INSTITUTION BY STATION NUMBER - PLEASE WAIT",!!!
; load va station number
D MAIN^XUMF04Q
W !!!,"PROCESS STATION NUMBER",!!!
D MAIN^XUMF04H
;
W !!!,"GET INSTITUTUION BY NPI",!!!
; load NPI
S XUMFCD="NPI"
D MAIN^XUMF04Q
W !!!,"PROCESS NPI",!!!
D MAIN^XUMF04H
W !!!,"DONE",!!!
;
Q
;
BG ; -- background job
;
N ZTRTN,ZTDESC,ZTDTH
;
S ZTRTN="EN^XUMF04Q"
S ZTDESC="XUMF load all national Institution data"
S ZTDTH=$$NOW^XLFDT
S ZTIO=""
;
D ^%ZTLOAD
;
Q
;
MAIN ; -- QUERY MESSAGE
;
N CNT,ERR,I,X,HLFS,HLCS,ERROR,HLRESLTA,IFN,IEN,TYPE
N VALUE,HLSCS,PROTOCOL,TEST
;
D INIT,BUILD,SEND,EXIT
;
Q
;
INIT ; -- initialize
;
K ^TMP("HLS",$J)
;
K HL,HLCS,HLDOM,HLECH,HLFS,HLINST,HLINSTN,HLL,HLMTIEN,HLNEXT
K HLNODE,HLP,HLPARAM,HLPROD,HLQ,HLQUIT,HLRESLT,HLSCS
;
S PROTOCOL=$O(^ORD(101,"B","XUMF 04 MFQ",0))
D INIT^HLFNC2(PROTOCOL,.HL)
S TEST=$S($P($$PARAM^HLCS2,U,3)="T":1,1:0)
S HLL("LINKS",1)="XUMF 04 MFR^XUMF "_$S('TEST:"FORUM",1:"TEST")
;
S ERROR=0,CNT=1
S HLFS=HL("FS"),HLCS=$E(HL("ECH")),HLSCS=$E(HL("ECH"),4)
;
Q
;
BUILD ; -- build message
;
D QRD
;
Q
;
MSA ; -- MSA segment
;
S ^TMP("HLS",$J,CNT)=$$MSA^XUMF04(ERROR,HLFS,.HL)
S CNT=CNT+1
;
Q
;
QRD ; -- QRD segment
;
S ^TMP("HLS",$J,CNT)=$$QRD^XUMF04(HLFS,$G(XUMFCD))
S CNT=CNT+1
;
Q
;
;
;
SEND ; -- send HL7 message
;
S HLP("PRIORITY")="I"
;
D DIRECT^HLMA(PROTOCOL,"GM",1,.HLRESLT,"",.HLP)
;
; 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("HLS",$J)
;
Q
;
DMIS ; - load DMIS
;
Q:$$KSP^XUPARAM("INST")=12000
Q:$P($$PARAM^HLCS2,U,3)="T"
;
N XUMFCD
S XUMFCD="DMIS"
D MAIN^XUMF04Q
D MAIN^XUMF04H
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUMF04Q 2372 printed Sep 23, 2025@19:46:22 Page 2
XUMF04Q ;BP/RAM - INSTITUTION QUERY ;06/28/00
+1 ;;8.0;KERNEL;**549,678**;Jul 10, 1995;Build 13
+2 ;;Per VA Directive 6402, this routine should not be modified
+3 QUIT
+4 ;
EN ; -- QUERY and PROCESS RESPONSE
+1 ;
+2 if $$KSP^XUPARAM("INST")=12000
QUIT
+3 if $PIECE($$PARAM^HLCS2,U,3)="T"
QUIT
+4 ;
+5 NEW XUMFCD
+6 ;
+7 MERGE ^TMP("XUMF 04",$$NOW^XLFDT,$JOB,4)=^DIC(4)
+8 ;
+9 WRITE !!!,"GET FACILITY TYPE",!!!
+10 ; load facility type
+11 DO LOAD^XUMF(4.1)
+12 ;
+13 WRITE !!!,"GET INSTITUTION BY STATION NUMBER - PLEASE WAIT",!!!
+14 ; load va station number
+15 DO MAIN^XUMF04Q
+16 WRITE !!!,"PROCESS STATION NUMBER",!!!
+17 DO MAIN^XUMF04H
+18 ;
+19 WRITE !!!,"GET INSTITUTUION BY NPI",!!!
+20 ; load NPI
+21 SET XUMFCD="NPI"
+22 DO MAIN^XUMF04Q
+23 WRITE !!!,"PROCESS NPI",!!!
+24 DO MAIN^XUMF04H
+25 WRITE !!!,"DONE",!!!
+26 ;
+27 QUIT
+28 ;
BG ; -- background job
+1 ;
+2 NEW ZTRTN,ZTDESC,ZTDTH
+3 ;
+4 SET ZTRTN="EN^XUMF04Q"
+5 SET ZTDESC="XUMF load all national Institution data"
+6 SET ZTDTH=$$NOW^XLFDT
+7 SET ZTIO=""
+8 ;
+9 DO ^%ZTLOAD
+10 ;
+11 QUIT
+12 ;
MAIN ; -- QUERY MESSAGE
+1 ;
+2 NEW CNT,ERR,I,X,HLFS,HLCS,ERROR,HLRESLTA,IFN,IEN,TYPE
+3 NEW VALUE,HLSCS,PROTOCOL,TEST
+4 ;
+5 DO INIT
DO BUILD
DO SEND
DO EXIT
+6 ;
+7 QUIT
+8 ;
INIT ; -- initialize
+1 ;
+2 KILL ^TMP("HLS",$JOB)
+3 ;
+4 KILL HL,HLCS,HLDOM,HLECH,HLFS,HLINST,HLINSTN,HLL,HLMTIEN,HLNEXT
+5 KILL HLNODE,HLP,HLPARAM,HLPROD,HLQ,HLQUIT,HLRESLT,HLSCS
+6 ;
+7 SET PROTOCOL=$ORDER(^ORD(101,"B","XUMF 04 MFQ",0))
+8 DO INIT^HLFNC2(PROTOCOL,.HL)
+9 SET TEST=$SELECT($PIECE($$PARAM^HLCS2,U,3)="T":1,1:0)
+10 SET HLL("LINKS",1)="XUMF 04 MFR^XUMF "_$SELECT('TEST:"FORUM",1:"TEST")
+11 ;
+12 SET ERROR=0
SET CNT=1
+13 SET HLFS=HL("FS")
SET HLCS=$EXTRACT(HL("ECH"))
SET HLSCS=$EXTRACT(HL("ECH"),4)
+14 ;
+15 QUIT
+16 ;
BUILD ; -- build message
+1 ;
+2 DO QRD
+3 ;
+4 QUIT
+5 ;
MSA ; -- MSA segment
+1 ;
+2 SET ^TMP("HLS",$JOB,CNT)=$$MSA^XUMF04(ERROR,HLFS,.HL)
+3 SET CNT=CNT+1
+4 ;
+5 QUIT
+6 ;
QRD ; -- QRD segment
+1 ;
+2 SET ^TMP("HLS",$JOB,CNT)=$$QRD^XUMF04(HLFS,$GET(XUMFCD))
+3 SET CNT=CNT+1
+4 ;
+5 QUIT
+6 ;
+7 ;
+8 ;
SEND ; -- send HL7 message
+1 ;
+2 SET HLP("PRIORITY")="I"
+3 ;
+4 DO DIRECT^HLMA(PROTOCOL,"GM",1,.HLRESLT,"",.HLP)
+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("HLS",$JOB)
+5 ;
+6 QUIT
+7 ;
DMIS ; - load DMIS
+1 ;
+2 if $$KSP^XUPARAM("INST")=12000
QUIT
+3 if $PIECE($$PARAM^HLCS2,U,3)="T"
QUIT
+4 ;
+5 NEW XUMFCD
+6 SET XUMFCD="DMIS"
+7 DO MAIN^XUMF04Q
+8 DO MAIN^XUMF04H
+9 ;
+10 QUIT
+11 ;
