- XUMF04Q ;BP/RAM - INSTITUTION QUERY ;06/28/00
- ;;8.0;KERNEL;**549,1018**;Jul 10, 1995;Build 12
- ;
- ;;IHS/OIT/FBD - 6/4/2015 - AS PART OF IHS PATCH XU*8.0*1018, ADDED LINE EN+2
- ; SKIP VA QUERY/RESPONSE ON IHS INSTITUTION FILE
- Q
- ;
- EN ; -- QUERY and PROCESS RESPONSE
- ;
- Q:$G(DUZ("AG"))="I" ;XU*8.0*1018
- 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
- ;
- XUMF04Q ;BP/RAM - INSTITUTION QUERY ;06/28/00
- +1 ;;8.0;KERNEL;**549,1018**;Jul 10, 1995;Build 12
- +2 ;
- +3 ;;IHS/OIT/FBD - 6/4/2015 - AS PART OF IHS PATCH XU*8.0*1018, ADDED LINE EN+2
- +4 ; SKIP VA QUERY/RESPONSE ON IHS INSTITUTION FILE
- +5 QUIT
- +6 ;
- EN ; -- QUERY and PROCESS RESPONSE
- +1 ;
- +2 ;XU*8.0*1018
- IF $GET(DUZ("AG"))="I"
- QUIT
- +3 IF $$KSP^XUPARAM("INST")=12000
- QUIT
- +4 IF $PIECE($$PARAM^HLCS2,U,3)="T"
- QUIT
- +5 ;
- +6 NEW XUMFCD
- +7 ;
- +8 MERGE ^TMP("XUMF 04",$$NOW^XLFDT,$JOB,4)=^DIC(4)
- +9 ;
- +10 WRITE !!!,"GET FACILITY TYPE",!!!
- +11 ; load facility type
- +12 DO LOAD^XUMF(4.1)
- +13 ;
- +14 WRITE !!!,"GET INSTITUTION BY STATION NUMBER - PLEASE WAIT",!!!
- +15 ; load va station number
- +16 DO MAIN^XUMF04Q
- +17 WRITE !!!,"PROCESS STATION NUMBER",!!!
- +18 DO MAIN^XUMF04H
- +19 ;
- +20 WRITE !!!,"GET INSTITUTUION BY NPI",!!!
- +21 ; load NPI
- +22 SET XUMFCD="NPI"
- +23 DO MAIN^XUMF04Q
- +24 WRITE !!!,"PROCESS NPI",!!!
- +25 DO MAIN^XUMF04H
- +26 WRITE !!!,"DONE",!!!
- +27 ;
- +28 QUIT
- +29 ;
- 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 ;
