- XUMFXH ;ISS/RAM - MFS Handler ;06/28/00
- ;;8.0;KERNEL;**299,382,383**;Jul 10, 1995
- ;
- ; This routine handles Master File HL7 messages.
- ;
- MAIN ; -- entry point
- ;
- N CNT,ERR,I,X,HLFS,HLCS,ERROR,HLRESLTA,IFN,IEN,MTPE,TYPE,ARRAY
- N HDT,KEY,MID,REASON,VALUE,XREF,ALL,GROUP,PARAM,ROOT,SEG,QRD,XUMF
- N QID,WHAT,WHO,HLSCS,CDSYS,EXIT,HLREP,NUMBER,Y,XXX,YYY,ERR,XIEN
- N XUMFSDS
- ;
- D INIT,PROCESS,REPLY^XUMFXACK(ERROR),EXIT
- ;
- Q
- ;
- INIT ; -- initialize
- ;
- K ^TMP("DILIST",$J),^TMP("DIERR",$J)
- K ^TMP("HLS",$J),^TMP("HLA",$J)
- K ^TMP("XUMF MFS",$J),^TMP("XUMF ERROR",$J)
- ;
- S XUMF=1,DUZ(0)="@"
- ;
- S (ERROR,CNT,TYPE,ARRAY,EXIT)=0
- S HLFS=HL("FS"),HLCS=$E(HL("ECH"))
- S HLSCS=$E(HL("ECH"),4),HLREP=$E(HL("ECH"),2)
- ;
- Q
- ;
- PROCESS ; -- pull message text
- ;
- F X HLNEXT Q:HLQUIT'>0 D
- .Q:$P(HLNODE,HLFS)=""
- .Q:"^MSH^MSA^QRD^MFI^MFE^RDF^RDT^"'[(U_$P(HLNODE,HLFS)_U)
- .D @($P(HLNODE,HLFS))
- ;
- Q
- ;
- MSH ; -- MSH segment
- ;
- Q
- ;
- MSA ; -- MSA segment
- ;
- N CODE
- ;
- S CODE=$P(HLNODE,HLFS,2)
- ;
- I CODE="AE"!(CODE="AR") D
- .S ERROR=ERROR_U_$P(HLNODE,HLFS,4)_U_$G(ERR)
- .D EM^XUMFX(ERROR,.ERR)
- ;
- Q
- ;
- MFI ; -- MFI segment
- ;
- Q:ERROR
- Q:EXIT
- ;
- K IFN,ARRAY,MFI
- ;
- I $P(HLNODE,HLFS,2)="" D Q
- .S ERROR="1^MFI segment missing Master File Identifier HLNODE: "_HLNODE
- .D EM^XUMFX(ERROR,.ERR)
- ;
- S MFI=$P(HLNODE,HLFS,2),IFN=MFI
- S:'IFN IFN=$O(^DIC(4.001,"MFI",$P(MFI,HLCS,2),0))
- S IFN=$S(IFN:IFN,MFI="ZMF":4.001,1:0)
- I 'IFN D Q
- .S ERROR="1^IFN in MFI could not be resolved HLNODE: "_HLNODE
- .D EM^XUMFX(ERROR,.ERR)
- ;
- ;sds flag=1; 1H is history record (use alt key for owning record)
- S XUMFSDS=$S($P(MFI,HLCS,3)="SDS":1,1:0)
- I XUMFSDS,MFI["History" S XUMFSDS="1H"
- ;
- S ARRAY=$S($G(ARRAY):1,$P(HLNODE,HLFS,3)="TEMP":1,1:0)
- ;
- Q
- ;
- MFE ; -- MFE segment
- ;
- Q:ERROR
- Q:EXIT
- ;
- K IEN
- ;
- N PRE,POST
- ;
- S KEY=$P(HLNODE,HLFS,5) Q:ARRAY
- ;
- S PRE=$P($G(^DIC(4.001,+IFN,"MFE")),U,16)
- I PRE'="" D Q:$G(EXIT)
- .S PRE=PRE_"^XUMFXR"
- .D @(PRE)
- ;
- D MFE^XUMFX(IFN,KEY,HLCS,.IEN,.ERROR) Q:ERROR
- ;
- S POST=$P($G(^DIC(4.001,+IFN,"MFE")),U,17)
- I POST'="" D Q:$G(EXIT)
- .S POST=POST_"^XUMFXR"
- .D @(POST)
- ;
- I 'IEN D Q
- .S ERROR="1^IEN not resolved in MFE File #: "_IFN_" HLNODE: "_HLNODE
- .D EM^XUMFX(ERROR,.ERR)
- .K ERR
- ;
- ; clean multiple flag
- K:'$D(XIEN(IEN)) XIEN
- S XIEN(IEN)=$G(XIEN(IEN))+1
- ;
- Q
- ;
- RDF ; -- table row definition
- ;
- Q:ERROR
- Q:EXIT
- ;
- I $G(ARRAY) D ARRAY Q
- ;
- N COL,X,Y,Z,DTYP,IDX,SEQ,VUID,DATA,NAME
- ;
- K ^TMP("XUMF MFS",$J,"PARAM","SEQ")
- K ^TMP("XUMF MFS",$J,"PARAM","MULT")
- K ^TMP("XUMF MFS",$J,"PARAM","IENS")
- ;
- K XXX,YYY
- ;
- D SEGPRSE^XUMFXHL7("HLNODE","XXX")
- S NUMBER=XXX(1)
- D SEQPRSE^XUMFXHL7("XXX(2)","COL") K XXX
- I $O(COL(99999),-1)'=NUMBER D Q
- .S ERROR="1^RDF number of columns error"
- .D EM^XUMFX("RDF segment columns don't match number",.ERROR)
- ;
- ;S NUMBER=$P(HLNODE,HLFS,2)
- ;S DATA=$P(HLNODE,HLFS,3)
- ;
- ;S CNT=0,Y=0
- ;F SEQ=1:1:NUMBER D
- ;.S Y=Y+1
- ;.S Z=$P(DATA,HLREP,Y)
- ;.I Y=$L(DATA,HLREP) D
- ;..S CNT=$O(HLNODE(CNT))
- ;..S DATA=$G(HLNODE(+CNT))
- ;..S Z=Z_$P(DATA,HLREP)
- ;..S Y=1
- ;.S COL(SEQ)=Z
- ;
- S SEQ=0
- F S SEQ=$O(COL(SEQ)) Q:'SEQ D
- .S NAME=COL(SEQ,1),TYP=COL(SEQ,2) Q:NAME=""
- .;S NAME=$P(COL(SEQ),HLCS) Q:NAME=""
- .S IDX=$O(^DIC(4.001,+IFN,1,"B",NAME,0)) Q:'IDX
- .S DATA=$G(^DIC(4.001,+IFN,1,+IDX,0)) Q:DATA=""
- .S YYY(NAME,SEQ)=""
- .;
- .;N FLD,TYP,SUBFILE,LKUP,REPEAT,CLEAN,TIMEZONE
- .;S TYP=$P(DATA,U,3),TYP=$$GET1^DIQ(771.4,(+TYP_","),.01)
- .N FLD,SUBFILE,LKUP,REPEAT,CLEAN,TIMEZONE
- .S FLD=$P(DATA,U,2),SUBFILE=$P(DATA,U,4)
- .S LKUP=$P(DATA,U,7),TIMEZONE=$P(DATA,U,14)
- .S REPEAT=$P(DATA,U,11),CLEAN=$P(DATA,U,12),VUID=$P(DATA,U,13)
- .S ^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"VUID")=VUID
- .;
- .I 'SUBFILE D Q
- ..S ^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,FLD)=TYP_U_LKUP
- .;
- .; -- multiple field
- .;
- .I $P(DATA,U,6)'="" D ;.01 is a field
- ..S XXX(SEQ)=$P(DATA,U,6)
- .;
- .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,"REPEAT")=REPEAT
- .S ^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"CLEAN")=CLEAN
- .S ^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"TIMEZONE")=TIMEZONE
- ;
- 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
- ;
- Q
- ;
- RDT ; -- table row data
- ;
- Q:ERROR
- Q:EXIT
- ;
- K XXX
- D SEGPRSE^XUMFXHL7("HLNODE","XXX")
- I $O(XXX(99999),-1)'=NUMBER D Q
- .S ERROR="1^RDF/RDT number of columns error"
- .D EM^XUMFX("RDF/RDT segment columns don't match number",.ERROR)
- ;
- I $G(ARRAY) D ARRAY Q
- ;
- Q:'IEN
- ;
- N FDA,IENS,FIELD,ERR,PRE,POST,MULT,FDA1,SEQ,VUID,TIMEZONE
- ;
- S PRE=$P($G(^DIC(4.001,+IFN,0)),U,4)
- I PRE'="" D
- .S PRE=PRE_"^XUMFR"
- .D @(PRE)
- ;
- S IENS=IEN_","
- S SEQ=0
- F S SEQ=$O(^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ)) Q:'SEQ D
- .S FIELD=$O(^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,0))
- .S VUID=$G(^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"VUID"))
- .S TIMEZONE=$G(^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"TIMEZONE"))
- .I 'FIELD D SUBFILE Q
- .S TYP=$G(^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,FIELD))
- .S VALUE=$$VALUE()
- .S VALUE=$$DTYP^XUMFXP(VALUE,TYP,HLCS,0,TIMEZONE)
- .S VALUE=$$VAL^XUMFX(IFN,FIELD,VUID,VALUE,IENS) Q:VALUE="^"
- .S FDA(IFN,IENS,FIELD)=VALUE
- ;
- M FDA=FDA1
- ;
- D:$D(FDA) FILE^DIE(,"FDA","ERR")
- I $D(ERR) D
- .S ERROR="1^updating error"
- .D EM^XUMFX("file DIE call error message in RDT",.ERR)
- .K ERR
- ;
- S POST=$P($G(^DIC(4.001,+IFN,0)),U,5)
- I POST'="" D
- .S POST=POST_"^XUMFR"
- .D @(POST)
- ;
- Q
- ;
- SUBFILE ; -- process subfile record
- ;
- N IFN,IENS1,KEY1,FIELD,TYP,MKEY,ERR,REPEAT,CLEAN
- ;
- S IFN=^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"FILE")
- S FIELD=^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"FIELD")
- S TYP=^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"DTYP")
- S REPEAT=^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"REPEAT")
- S CLEAN=^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"CLEAN")
- ;
- I CLEAN,$G(XIEN(IEN))'>1 D
- .N ROOT,IDX
- .S ROOT=$$ROOT^DILFD(IFN,","_IENS,1)
- .S IDX=0 F S IDX=$O(@ROOT@(IDX)) Q:'IDX D
- ..D
- ...N DA,DIK,DIC S DA(1)=+IENS,DA=IDX,DIK=$P(ROOT,")")_"," D ^DIK
- ;
- S VALUE=$$VALUE()
- S VALUE=$$DTYP^XUMFXP(VALUE,TYP,HLCS,0,TIMEZONE)
- ;
- S MULT=$G(^TMP("XUMF MFS",$J,"PARAM","MULT",SEQ))
- ;
- I MULT=SEQ Q:VALUE="" D
- .N FDA,IEN
- .S VALUE=$$VAL^XUMFX(IFN,FIELD,VUID,VALUE,"?+1,"_IENS) Q:VALUE="^"
- .S FDA(IFN,"?+1,"_IENS,.01)=VALUE
- .D UPDATE^DIE(,"FDA","IEN","ERR")
- .I $D(ERR) D Q
- ..S ERROR="1^subfile update error SUBFILE#: "_IFN
- ..D EM^XUMFX("update DIE call error message in SUBFILE",.ERR)
- ..K ERR
- .S IENS1=IEN(1)_","_IENS,MULT(SEQ)=IENS1
- ;
- I MULT,MULT'=SEQ S IENS1=$G(MULT(+MULT)) Q:IENS1=""
- S:MULT'=SEQ VALUE=$$VAL^XUMFX(IFN,FIELD,VUID,VALUE,"?+1,"_IENS) Q:VALUE="^"
- S:$D(IENS1) FDA1(IFN,IENS1,FIELD)=VALUE
- ;
- Q
- ;
- VALUE() ; -- handle HL7 continuation nodes
- ;
- Q:'$O(HLNODE(0)) $P(HLNODE,HLFS,SEQ+1)
- ;
- N COL
- ;
- D SEGPRSE^XUMFXHL7("HLNODE","COL")
- ;
- Q COL(SEQ)
- ;
- ARRAY ; -- query data stored in array (not filed)
- ;
- N X S X=KEY S X=$S($P(X,HLCS)'="":$P(X,HLCS),1:$P(X,HLCS,4)) Q:X=""
- ;
- M ^TMP("XUMF ARRAY",$J,IFN,X)=HLNODE
- ;
- Q
- ;
- EXIT ; -- cleanup, and quit
- ;
- ; post processing logic
- S X=$G(^DIC(4.001,+IFN,2)) X:X'="" X
- ;
- K ^TMP("DILIST",$J),^TMP("DIERR",$J),^TMP("HLS",$J),^TMP("HLA",$J)
- ;
- K ^TMP("XUMF MFS",$J),^TMP("XUMF ERROR",$J)
- ;
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUMFXH 7580 printed Jan 18, 2025@03:12:19 Page 2
- XUMFXH ;ISS/RAM - MFS Handler ;06/28/00
- +1 ;;8.0;KERNEL;**299,382,383**;Jul 10, 1995
- +2 ;
- +3 ; This routine handles Master File HL7 messages.
- +4 ;
- MAIN ; -- entry point
- +1 ;
- +2 NEW CNT,ERR,I,X,HLFS,HLCS,ERROR,HLRESLTA,IFN,IEN,MTPE,TYPE,ARRAY
- +3 NEW HDT,KEY,MID,REASON,VALUE,XREF,ALL,GROUP,PARAM,ROOT,SEG,QRD,XUMF
- +4 NEW QID,WHAT,WHO,HLSCS,CDSYS,EXIT,HLREP,NUMBER,Y,XXX,YYY,ERR,XIEN
- +5 NEW XUMFSDS
- +6 ;
- +7 DO INIT
- DO PROCESS
- DO REPLY^XUMFXACK(ERROR)
- DO EXIT
- +8 ;
- +9 QUIT
- +10 ;
- INIT ; -- initialize
- +1 ;
- +2 KILL ^TMP("DILIST",$JOB),^TMP("DIERR",$JOB)
- +3 KILL ^TMP("HLS",$JOB),^TMP("HLA",$JOB)
- +4 KILL ^TMP("XUMF MFS",$JOB),^TMP("XUMF ERROR",$JOB)
- +5 ;
- +6 SET XUMF=1
- SET DUZ(0)="@"
- +7 ;
- +8 SET (ERROR,CNT,TYPE,ARRAY,EXIT)=0
- +9 SET HLFS=HL("FS")
- SET HLCS=$EXTRACT(HL("ECH"))
- +10 SET HLSCS=$EXTRACT(HL("ECH"),4)
- SET HLREP=$EXTRACT(HL("ECH"),2)
- +11 ;
- +12 QUIT
- +13 ;
- PROCESS ; -- pull message text
- +1 ;
- +2 FOR
- XECUTE HLNEXT
- if HLQUIT'>0
- QUIT
- Begin DoDot:1
- +3 if $PIECE(HLNODE,HLFS)=""
- QUIT
- +4 if "^MSH^MSA^QRD^MFI^MFE^RDF^RDT^"'[(U_$PIECE(HLNODE,HLFS)_U)
- QUIT
- +5 DO @($PIECE(HLNODE,HLFS))
- End DoDot:1
- +6 ;
- +7 QUIT
- +8 ;
- MSH ; -- MSH segment
- +1 ;
- +2 QUIT
- +3 ;
- MSA ; -- MSA segment
- +1 ;
- +2 NEW CODE
- +3 ;
- +4 SET CODE=$PIECE(HLNODE,HLFS,2)
- +5 ;
- +6 IF CODE="AE"!(CODE="AR")
- Begin DoDot:1
- +7 SET ERROR=ERROR_U_$PIECE(HLNODE,HLFS,4)_U_$GET(ERR)
- +8 DO EM^XUMFX(ERROR,.ERR)
- End DoDot:1
- +9 ;
- +10 QUIT
- +11 ;
- MFI ; -- MFI segment
- +1 ;
- +2 if ERROR
- QUIT
- +3 if EXIT
- QUIT
- +4 ;
- +5 KILL IFN,ARRAY,MFI
- +6 ;
- +7 IF $PIECE(HLNODE,HLFS,2)=""
- Begin DoDot:1
- +8 SET ERROR="1^MFI segment missing Master File Identifier HLNODE: "_HLNODE
- +9 DO EM^XUMFX(ERROR,.ERR)
- End DoDot:1
- QUIT
- +10 ;
- +11 SET MFI=$PIECE(HLNODE,HLFS,2)
- SET IFN=MFI
- +12 if 'IFN
- SET IFN=$ORDER(^DIC(4.001,"MFI",$PIECE(MFI,HLCS,2),0))
- +13 SET IFN=$SELECT(IFN:IFN,MFI="ZMF":4.001,1:0)
- +14 IF 'IFN
- Begin DoDot:1
- +15 SET ERROR="1^IFN in MFI could not be resolved HLNODE: "_HLNODE
- +16 DO EM^XUMFX(ERROR,.ERR)
- End DoDot:1
- QUIT
- +17 ;
- +18 ;sds flag=1; 1H is history record (use alt key for owning record)
- +19 SET XUMFSDS=$SELECT($PIECE(MFI,HLCS,3)="SDS":1,1:0)
- +20 IF XUMFSDS
- IF MFI["History"
- SET XUMFSDS="1H"
- +21 ;
- +22 SET ARRAY=$SELECT($GET(ARRAY):1,$PIECE(HLNODE,HLFS,3)="TEMP":1,1:0)
- +23 ;
- +24 QUIT
- +25 ;
- MFE ; -- MFE segment
- +1 ;
- +2 if ERROR
- QUIT
- +3 if EXIT
- QUIT
- +4 ;
- +5 KILL IEN
- +6 ;
- +7 NEW PRE,POST
- +8 ;
- +9 SET KEY=$PIECE(HLNODE,HLFS,5)
- if ARRAY
- QUIT
- +10 ;
- +11 SET PRE=$PIECE($GET(^DIC(4.001,+IFN,"MFE")),U,16)
- +12 IF PRE'=""
- Begin DoDot:1
- +13 SET PRE=PRE_"^XUMFXR"
- +14 DO @(PRE)
- End DoDot:1
- if $GET(EXIT)
- QUIT
- +15 ;
- +16 DO MFE^XUMFX(IFN,KEY,HLCS,.IEN,.ERROR)
- if ERROR
- QUIT
- +17 ;
- +18 SET POST=$PIECE($GET(^DIC(4.001,+IFN,"MFE")),U,17)
- +19 IF POST'=""
- Begin DoDot:1
- +20 SET POST=POST_"^XUMFXR"
- +21 DO @(POST)
- End DoDot:1
- if $GET(EXIT)
- QUIT
- +22 ;
- +23 IF 'IEN
- Begin DoDot:1
- +24 SET ERROR="1^IEN not resolved in MFE File #: "_IFN_" HLNODE: "_HLNODE
- +25 DO EM^XUMFX(ERROR,.ERR)
- +26 KILL ERR
- End DoDot:1
- QUIT
- +27 ;
- +28 ; clean multiple flag
- +29 if '$DATA(XIEN(IEN))
- KILL XIEN
- +30 SET XIEN(IEN)=$GET(XIEN(IEN))+1
- +31 ;
- +32 QUIT
- +33 ;
- RDF ; -- table row definition
- +1 ;
- +2 if ERROR
- QUIT
- +3 if EXIT
- QUIT
- +4 ;
- +5 IF $GET(ARRAY)
- DO ARRAY
- QUIT
- +6 ;
- +7 NEW COL,X,Y,Z,DTYP,IDX,SEQ,VUID,DATA,NAME
- +8 ;
- +9 KILL ^TMP("XUMF MFS",$JOB,"PARAM","SEQ")
- +10 KILL ^TMP("XUMF MFS",$JOB,"PARAM","MULT")
- +11 KILL ^TMP("XUMF MFS",$JOB,"PARAM","IENS")
- +12 ;
- +13 KILL XXX,YYY
- +14 ;
- +15 DO SEGPRSE^XUMFXHL7("HLNODE","XXX")
- +16 SET NUMBER=XXX(1)
- +17 DO SEQPRSE^XUMFXHL7("XXX(2)","COL")
- KILL XXX
- +18 IF $ORDER(COL(99999),-1)'=NUMBER
- Begin DoDot:1
- +19 SET ERROR="1^RDF number of columns error"
- +20 DO EM^XUMFX("RDF segment columns don't match number",.ERROR)
- End DoDot:1
- QUIT
- +21 ;
- +22 ;S NUMBER=$P(HLNODE,HLFS,2)
- +23 ;S DATA=$P(HLNODE,HLFS,3)
- +24 ;
- +25 ;S CNT=0,Y=0
- +26 ;F SEQ=1:1:NUMBER D
- +27 ;.S Y=Y+1
- +28 ;.S Z=$P(DATA,HLREP,Y)
- +29 ;.I Y=$L(DATA,HLREP) D
- +30 ;..S CNT=$O(HLNODE(CNT))
- +31 ;..S DATA=$G(HLNODE(+CNT))
- +32 ;..S Z=Z_$P(DATA,HLREP)
- +33 ;..S Y=1
- +34 ;.S COL(SEQ)=Z
- +35 ;
- +36 SET SEQ=0
- +37 FOR
- SET SEQ=$ORDER(COL(SEQ))
- if 'SEQ
- QUIT
- Begin DoDot:1
- +38 SET NAME=COL(SEQ,1)
- SET TYP=COL(SEQ,2)
- if NAME=""
- QUIT
- +39 ;S NAME=$P(COL(SEQ),HLCS) Q:NAME=""
- +40 SET IDX=$ORDER(^DIC(4.001,+IFN,1,"B",NAME,0))
- if 'IDX
- QUIT
- +41 SET DATA=$GET(^DIC(4.001,+IFN,1,+IDX,0))
- if DATA=""
- QUIT
- +42 SET YYY(NAME,SEQ)=""
- +43 ;
- +44 ;N FLD,TYP,SUBFILE,LKUP,REPEAT,CLEAN,TIMEZONE
- +45 ;S TYP=$P(DATA,U,3),TYP=$$GET1^DIQ(771.4,(+TYP_","),.01)
- +46 NEW FLD,SUBFILE,LKUP,REPEAT,CLEAN,TIMEZONE
- +47 SET FLD=$PIECE(DATA,U,2)
- SET SUBFILE=$PIECE(DATA,U,4)
- +48 SET LKUP=$PIECE(DATA,U,7)
- SET TIMEZONE=$PIECE(DATA,U,14)
- +49 SET REPEAT=$PIECE(DATA,U,11)
- SET CLEAN=$PIECE(DATA,U,12)
- SET VUID=$PIECE(DATA,U,13)
- +50 SET ^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"VUID")=VUID
- +51 ;
- +52 IF 'SUBFILE
- Begin DoDot:2
- +53 SET ^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,FLD)=TYP_U_LKUP
- End DoDot:2
- QUIT
- +54 ;
- +55 ; -- multiple field
- +56 ;
- +57 ;.01 is a field
- IF $PIECE(DATA,U,6)'=""
- Begin DoDot:2
- +58 SET XXX(SEQ)=$PIECE(DATA,U,6)
- End DoDot:2
- +59 ;
- +60 SET ^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"FILE")=SUBFILE
- +61 SET ^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"FIELD")=FLD
- +62 SET ^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"DTYP")=TYP
- +63 SET ^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"REPEAT")=REPEAT
- +64 SET ^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"CLEAN")=CLEAN
- +65 SET ^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"TIMEZONE")=TIMEZONE
- End DoDot:1
- +66 ;
- +67 SET SEQ=0
- +68 FOR
- SET SEQ=$ORDER(XXX(SEQ))
- if 'SEQ
- QUIT
- Begin DoDot:1
- +69 SET X=XXX(SEQ)
- SET Y=$ORDER(YYY(X,0))
- +70 SET ^TMP("XUMF MFS",$JOB,"PARAM","MULT",SEQ)=Y
- End DoDot:1
- +71 ;
- +72 QUIT
- +73 ;
- RDT ; -- table row data
- +1 ;
- +2 if ERROR
- QUIT
- +3 if EXIT
- QUIT
- +4 ;
- +5 KILL XXX
- +6 DO SEGPRSE^XUMFXHL7("HLNODE","XXX")
- +7 IF $ORDER(XXX(99999),-1)'=NUMBER
- Begin DoDot:1
- +8 SET ERROR="1^RDF/RDT number of columns error"
- +9 DO EM^XUMFX("RDF/RDT segment columns don't match number",.ERROR)
- End DoDot:1
- QUIT
- +10 ;
- +11 IF $GET(ARRAY)
- DO ARRAY
- QUIT
- +12 ;
- +13 if 'IEN
- QUIT
- +14 ;
- +15 NEW FDA,IENS,FIELD,ERR,PRE,POST,MULT,FDA1,SEQ,VUID,TIMEZONE
- +16 ;
- +17 SET PRE=$PIECE($GET(^DIC(4.001,+IFN,0)),U,4)
- +18 IF PRE'=""
- Begin DoDot:1
- +19 SET PRE=PRE_"^XUMFR"
- +20 DO @(PRE)
- End DoDot:1
- +21 ;
- +22 SET IENS=IEN_","
- +23 SET SEQ=0
- +24 FOR
- SET SEQ=$ORDER(^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ))
- if 'SEQ
- QUIT
- Begin DoDot:1
- +25 SET FIELD=$ORDER(^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,0))
- +26 SET VUID=$GET(^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"VUID"))
- +27 SET TIMEZONE=$GET(^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"TIMEZONE"))
- +28 IF 'FIELD
- DO SUBFILE
- QUIT
- +29 SET TYP=$GET(^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,FIELD))
- +30 SET VALUE=$$VALUE()
- +31 SET VALUE=$$DTYP^XUMFXP(VALUE,TYP,HLCS,0,TIMEZONE)
- +32 SET VALUE=$$VAL^XUMFX(IFN,FIELD,VUID,VALUE,IENS)
- if VALUE="^"
- QUIT
- +33 SET FDA(IFN,IENS,FIELD)=VALUE
- End DoDot:1
- +34 ;
- +35 MERGE FDA=FDA1
- +36 ;
- +37 if $DATA(FDA)
- DO FILE^DIE(,"FDA","ERR")
- +38 IF $DATA(ERR)
- Begin DoDot:1
- +39 SET ERROR="1^updating error"
- +40 DO EM^XUMFX("file DIE call error message in RDT",.ERR)
- +41 KILL ERR
- End DoDot:1
- +42 ;
- +43 SET POST=$PIECE($GET(^DIC(4.001,+IFN,0)),U,5)
- +44 IF POST'=""
- Begin DoDot:1
- +45 SET POST=POST_"^XUMFR"
- +46 DO @(POST)
- End DoDot:1
- +47 ;
- +48 QUIT
- +49 ;
- SUBFILE ; -- process subfile record
- +1 ;
- +2 NEW IFN,IENS1,KEY1,FIELD,TYP,MKEY,ERR,REPEAT,CLEAN
- +3 ;
- +4 SET IFN=^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"FILE")
- +5 SET FIELD=^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"FIELD")
- +6 SET TYP=^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"DTYP")
- +7 SET REPEAT=^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"REPEAT")
- +8 SET CLEAN=^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"CLEAN")
- +9 ;
- +10 IF CLEAN
- IF $GET(XIEN(IEN))'>1
- Begin DoDot:1
- +11 NEW ROOT,IDX
- +12 SET ROOT=$$ROOT^DILFD(IFN,","_IENS,1)
- +13 SET IDX=0
- FOR
- SET IDX=$ORDER(@ROOT@(IDX))
- if 'IDX
- QUIT
- Begin DoDot:2
- +14 Begin DoDot:3
- +15 NEW DA,DIK,DIC
- SET DA(1)=+IENS
- SET DA=IDX
- SET DIK=$PIECE(ROOT,")")_","
- DO ^DIK
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +16 ;
- +17 SET VALUE=$$VALUE()
- +18 SET VALUE=$$DTYP^XUMFXP(VALUE,TYP,HLCS,0,TIMEZONE)
- +19 ;
- +20 SET MULT=$GET(^TMP("XUMF MFS",$JOB,"PARAM","MULT",SEQ))
- +21 ;
- +22 IF MULT=SEQ
- if VALUE=""
- QUIT
- Begin DoDot:1
- +23 NEW FDA,IEN
- +24 SET VALUE=$$VAL^XUMFX(IFN,FIELD,VUID,VALUE,"?+1,"_IENS)
- if VALUE="^"
- QUIT
- +25 SET FDA(IFN,"?+1,"_IENS,.01)=VALUE
- +26 DO UPDATE^DIE(,"FDA","IEN","ERR")
- +27 IF $DATA(ERR)
- Begin DoDot:2
- +28 SET ERROR="1^subfile update error SUBFILE#: "_IFN
- +29 DO EM^XUMFX("update DIE call error message in SUBFILE",.ERR)
- +30 KILL ERR
- End DoDot:2
- QUIT
- +31 SET IENS1=IEN(1)_","_IENS
- SET MULT(SEQ)=IENS1
- End DoDot:1
- +32 ;
- +33 IF MULT
- IF MULT'=SEQ
- SET IENS1=$GET(MULT(+MULT))
- if IENS1=""
- QUIT
- +34 if MULT'=SEQ
- SET VALUE=$$VAL^XUMFX(IFN,FIELD,VUID,VALUE,"?+1,"_IENS)
- if VALUE="^"
- QUIT
- +35 if $DATA(IENS1)
- SET FDA1(IFN,IENS1,FIELD)=VALUE
- +36 ;
- +37 QUIT
- +38 ;
- VALUE() ; -- handle HL7 continuation nodes
- +1 ;
- +2 if '$ORDER(HLNODE(0))
- QUIT $PIECE(HLNODE,HLFS,SEQ+1)
- +3 ;
- +4 NEW COL
- +5 ;
- +6 DO SEGPRSE^XUMFXHL7("HLNODE","COL")
- +7 ;
- +8 QUIT COL(SEQ)
- +9 ;
- ARRAY ; -- query data stored in array (not filed)
- +1 ;
- +2 NEW X
- SET X=KEY
- SET X=$SELECT($PIECE(X,HLCS)'="":$PIECE(X,HLCS),1:$PIECE(X,HLCS,4))
- if X=""
- QUIT
- +3 ;
- +4 MERGE ^TMP("XUMF ARRAY",$JOB,IFN,X)=HLNODE
- +5 ;
- +6 QUIT
- +7 ;
- EXIT ; -- cleanup, and quit
- +1 ;
- +2 ; post processing logic
- +3 SET X=$GET(^DIC(4.001,+IFN,2))
- if X'=""
- XECUTE X
- +4 ;
- +5 KILL ^TMP("DILIST",$JOB),^TMP("DIERR",$JOB),^TMP("HLS",$JOB),^TMP("HLA",$JOB)
- +6 ;
- +7 KILL ^TMP("XUMF MFS",$JOB),^TMP("XUMF ERROR",$JOB)
- +8 ;
- +9 QUIT
- +10 ;