MCORMN0 ;WISC/DCB-HL7 MESSAGE BUILDER ;7/23/99 09:08
;;1.0;CLINICAL PROCEDURES;**5**;Apr 01, 2004;Build 1
W !,"This is not a valid entry point" Q
BUILD(RAP,MCDFN,SAP,SNF,RNF,MST,PCI,VID,MCLINE,MSTR,MCDEST,MCPROC,MCFILE,MCREC,SDATE,ATYPE) ; Build the message
K ^TMP("MCORMN",$J)
N MCERR,MCOR,MCOR1,MCOR2,MCOR3,MCOR4,MSE,OBR,HLECH
N LOOP,MCDS,ST,MSE,MCHOLD,MCHOLD
S MSE=0,HLECH=$E(MSTR,2,4) D SLIP(MSTR)
S MCHOLD=+$O(^MCAR(697.2,"B",MCPROC,""))
S MCHOLD=$P($G(^MCAR(697.2,MCHOLD,0)),U,8)
S MCERR=$$GETDATA^MCORMN1(MCPROC,MCREC,"^TMP(""MCORMN"",$J)",MCFILE,ATYPE) Q:MCERR=0 1
S MCHOLD=$S(MCHOLD="":MCPROC,1:MCHOLD)
D SETNODE(MCDEST,$$MSH^MCORMN01(MCHOLD,SAP,SNF,RAP,RNF,MST,PCI,VID))
D SETNODE(MCDEST,$$PID^MCORMN01(MCDFN))
D SETNODE(MCDEST,$$OBR1^MCORMN01(SDATE,MCPROC,MCREC,MCFILE)) S OBR=MCLINE
S MCOR1=""
F S MCOR1=$O(^TMP("MCORMN",$J,"E",MCOR1)) Q:MCOR1="" D
.S MCOR2=""
.F S MCOR2=$O(^TMP("MCORMN",$J,"E",MCOR1,MCOR2)) Q:MCOR2="" D
..S MCOR3=""
..F S MCOR3=$O(^TMP("MCORMN",$J,"E",MCOR1,MCOR2,MCOR3)) Q:MCOR3="" D
...D GETDATA(RAP,MCDEST,OBR,MCOR1,MCOR2,MCOR3)
I +$P($G(^MCAR(MCFILE,MCREC,2005,0)),U,4)>0 D
.N OBI,OBR,OSI,VTI,UNT,RNG
.S OBI=MCFILE_ST(3)_"2005"_ST(3)_"P"_ST(2)_"IMAGES?"_ST(2)_"DD"
.S OBR="Images are associated with this procedure"
.S OSI="",VTI="",FILETYPE="P",UNT="",RNG=""
.D SETOBX1(FILETYPE,VTI,OBI,OSI,OBR),SETOBX2(UNT,RNG)
Q 0
GETDATA(RAP,MCDEST,OBR,MCOR1,MCOR2,MCOR3) ; Process the Data
N TMP1,TMP,HL7,TYPE
S TMP=$G(^TMP("MCORMN",$J,"F",MCOR1,MCOR3,0))
S HL7=$G(^TMP("MCORMN",$J,"F",MCOR1,MCOR3,1))
S TYPE=$P(HL7,U,7)
I (TYPE'="OBR"),(TYPE'="INFO"),(RAP="Health Summary") S TYPE="DD"
Q:(TYPE="INFO")!(TYPE="MISC")!(TYPE="")
S TMP1="D "_TYPE_"(TMP,HL7,OBR,MCOR1,MCOR2,MCOR3)" X TMP1
Q
ICD9(TMP,HL7,OBX,MCOR1,MCOR2,MCOR3) ; This is the ICD9 message builder for OBX
N OID,VT1,UNT,OSI,OBI,RNG,RST,DA,DIC,DR,DIQ,XTMP,CONT
S OBI="ICD9",OSI="",MST=$G(MST)+1,OSI=MST,CONT=""
S VTI=$P(HL7,U,2) S:VTI="" VTI="CE"
S UNT="",RNG="",RST=$G(^TMP("MCORMN",$J,"E",MCOR1,MCOR2,MCOR3,1)) Q:RST=""
;S DA=$O(^ICD9("B",RST,"")) Q:DA=""
Q
S DIC="^ICD9(",DR=".01;3",DIQ="XTMP(" D EN^DIQ1
S RST=XTMP(80,DA,.01)_ST(2)_XTMP(80,DA,3)_ST(2)_"ICD9"
D SETOBX1("",VTI,OBI,OSI,RST)
Q
ASTM(TMP,HL7,OBX,MCOR1,MCOR2,MCOR3) ; This is the ASTM message builder for OBX
N ASTM,ASTME,VTI,UNT,RNG,RST,OSI,OBI,FILETYPE
S FILETYPE=$P(TMP,U,2),OSI=""
S ASTM=$P(HL7,U,1),ASTME=$G(^MCAR(690.5,ASTM,0))
S ASTM=$P(ASTME,U,1)_$P(ASTME,U,2),VTI=$P(HL7,U,2)
S OBI=ASTM_ST(2)_$P(ASTME,U,3)_ST(2)_"CPT4"
S UNT=$P(HL7,U,3),RNG=$P(HL7,U,4)
D RDATA(VTI,OBI,OSI,UNT,RNG,FILETYPE,MCOR1,MCOR2,MCOR3)
Q
SUM(TMP,HL7,OBX,MCOR1,MCOR2,MCOR3) ; This is the miss. message builder for OBX
N FILETYPE,VTI,UNT,RNG,RST,OSI,OBI
S FILETYPE=$P(TMP,U,2),OSI=""
S OBI="SST",(UNT,RNG)="",OSI=""
S VTI="TX"
D RDATA(VTI,OBI,OSI,UNT,RNG,FILETYPE,MCOR1,MCOR2,MCOR3)
Q
DD(TMP,HL7,OBX,MCOR1,MCOR2,MCOR3) ; This is the DD mesage builder for OBX
N FLDNAME,VTI,OBI,OSI,UNT,RNG,FILETYPE,FLDNAME
S FILETYPE=$P(TMP,U,2),FLDNAME=$P(TMP,"^",1),OSI=""
S VTI=$P(HL7,U,2),OBI=MCOR1_ST(3)_MCOR3_ST(3)_FILETYPE_ST(2)_FLDNAME_ST(2)_"DD"
S UNT=$P(HL7,U,3),RNG=$P(HL7,U,4)
D RDATA(VTI,OBI,OSI,UNT,RNG,FILETYPE,MCOR1,MCOR2,MCOR3)
Q
OBR(TMP,HL7,OBX,MCOR1,MCOR2,MCOR3) ; This is the OBR add on message
N RST,PIECE,FILETYPE
S FILETYPE=$P(TMP,U,2),RST=$G(^TMP("MCORMN",$J,"E",MCOR1,MCOR2,MCOR3,1))
S RST=$$CONVERT^MCORMN01(FILETYPE,RST),PIECE=$P(HL7,U,6)+1
S $P(@MCDEST@(OBX),ST(1),PIECE)=RST
Q
RDATA(VTI,OBI,OSI,UNT,RNG,FILETYPE,MCOR1,MCOR2,MCOR3) ;
N MCOR4,CONT,LEN,RSTT,TEMP,COUNT,END,RST,CNT,LOOP,LOOP2,X,DIWL,DIWR,DIWF
S MCOR4=""
F LOOP=1:1 S MCOR4=$O(^TMP("MCORMN",$J,"E",MCOR1,MCOR2,MCOR3,MCOR4)) Q:MCOR4="" D
.S X=^TMP("MCORMN",$J,"E",MCOR1,MCOR2,MCOR3,MCOR4)
.;I $L(X)>80 D WP
.I $L(X)>80 D
..D WP
.E D
..D:LOOP=1 SETOBX1(FILETYPE,VTI,OBI,OSI,X)
..D:LOOP'=1 SETNODE(MCDEST,X)
D SETOBX2(UNT,RNG)
Q
WP ;
K ^UTILITY($J,"W") S DIWL=0,DIWR=80,DIWF="" D ^DIWP
S CNT=^UTILITY($J,"W",0)
F LOOP2=1:1:CNT S RST=^UTILITY($J,"W",0,LOOP2,0) D
.I (LOOP2>1)!(LOOP>1) D SETNODE(MCDEST,RST)
.E D SETOBX1(FILETYPE,VTI,OBI,OSI,RST)
K ^UTILITY($J,"W")
Q
SETOBX1(FILETYPE,VTI,OBI,OSI,OBR) ; Sets the first part of QBX line
S:VTI="" VTI="ST"
S:OSI="" (MSE,OSI)=$G(MSE)+1
D SETNODE(MCDEST,$$OBX1^MCORMN01(FILETYPE,VTI,OBI,OSI,OBR))
Q
SETOBX2(RNG,UNT) ;Sets the second part of OBX line
S @MCDEST@(MCLINE,0)=@MCDEST@(MCLINE,0)_$$OBX2^MCORMN01(RNG,UNT)
Q
SETNODE(NODE,VALUE) ;Set the node with the HL7 message string
S MCLINE=MCLINE+1,@NODE@(MCLINE,0)=VALUE
Q
SLIP(MSTR) ;Seperate the delimiters
F LOOP=1:1:5 S ST(LOOP)=$E(MSTR,LOOP,LOOP)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCORMN0 4770 printed Apr 09, 2024@21:15:47 Page 2
MCORMN0 ;WISC/DCB-HL7 MESSAGE BUILDER ;7/23/99 09:08
+1 ;;1.0;CLINICAL PROCEDURES;**5**;Apr 01, 2004;Build 1
+2 WRITE !,"This is not a valid entry point"
QUIT
BUILD(RAP,MCDFN,SAP,SNF,RNF,MST,PCI,VID,MCLINE,MSTR,MCDEST,MCPROC,MCFILE,MCREC,SDATE,ATYPE) ; Build the message
+1 KILL ^TMP("MCORMN",$JOB)
+2 NEW MCERR,MCOR,MCOR1,MCOR2,MCOR3,MCOR4,MSE,OBR,HLECH
+3 NEW LOOP,MCDS,ST,MSE,MCHOLD,MCHOLD
+4 SET MSE=0
SET HLECH=$EXTRACT(MSTR,2,4)
DO SLIP(MSTR)
+5 SET MCHOLD=+$ORDER(^MCAR(697.2,"B",MCPROC,""))
+6 SET MCHOLD=$PIECE($GET(^MCAR(697.2,MCHOLD,0)),U,8)
+7 SET MCERR=$$GETDATA^MCORMN1(MCPROC,MCREC,"^TMP(""MCORMN"",$J)",MCFILE,ATYPE)
if MCERR=0
QUIT 1
+8 SET MCHOLD=$SELECT(MCHOLD="":MCPROC,1:MCHOLD)
+9 DO SETNODE(MCDEST,$$MSH^MCORMN01(MCHOLD,SAP,SNF,RAP,RNF,MST,PCI,VID))
+10 DO SETNODE(MCDEST,$$PID^MCORMN01(MCDFN))
+11 DO SETNODE(MCDEST,$$OBR1^MCORMN01(SDATE,MCPROC,MCREC,MCFILE))
SET OBR=MCLINE
+12 SET MCOR1=""
+13 FOR
SET MCOR1=$ORDER(^TMP("MCORMN",$JOB,"E",MCOR1))
if MCOR1=""
QUIT
Begin DoDot:1
+14 SET MCOR2=""
+15 FOR
SET MCOR2=$ORDER(^TMP("MCORMN",$JOB,"E",MCOR1,MCOR2))
if MCOR2=""
QUIT
Begin DoDot:2
+16 SET MCOR3=""
+17 FOR
SET MCOR3=$ORDER(^TMP("MCORMN",$JOB,"E",MCOR1,MCOR2,MCOR3))
if MCOR3=""
QUIT
Begin DoDot:3
+18 DO GETDATA(RAP,MCDEST,OBR,MCOR1,MCOR2,MCOR3)
End DoDot:3
End DoDot:2
End DoDot:1
+19 IF +$PIECE($GET(^MCAR(MCFILE,MCREC,2005,0)),U,4)>0
Begin DoDot:1
+20 NEW OBI,OBR,OSI,VTI,UNT,RNG
+21 SET OBI=MCFILE_ST(3)_"2005"_ST(3)_"P"_ST(2)_"IMAGES?"_ST(2)_"DD"
+22 SET OBR="Images are associated with this procedure"
+23 SET OSI=""
SET VTI=""
SET FILETYPE="P"
SET UNT=""
SET RNG=""
+24 DO SETOBX1(FILETYPE,VTI,OBI,OSI,OBR)
DO SETOBX2(UNT,RNG)
End DoDot:1
+25 QUIT 0
GETDATA(RAP,MCDEST,OBR,MCOR1,MCOR2,MCOR3) ; Process the Data
+1 NEW TMP1,TMP,HL7,TYPE
+2 SET TMP=$GET(^TMP("MCORMN",$JOB,"F",MCOR1,MCOR3,0))
+3 SET HL7=$GET(^TMP("MCORMN",$JOB,"F",MCOR1,MCOR3,1))
+4 SET TYPE=$PIECE(HL7,U,7)
+5 IF (TYPE'="OBR")
IF (TYPE'="INFO")
IF (RAP="Health Summary")
SET TYPE="DD"
+6 if (TYPE="INFO")!(TYPE="MISC")!(TYPE="")
QUIT
+7 SET TMP1="D "_TYPE_"(TMP,HL7,OBR,MCOR1,MCOR2,MCOR3)"
XECUTE TMP1
+8 QUIT
ICD9(TMP,HL7,OBX,MCOR1,MCOR2,MCOR3) ; This is the ICD9 message builder for OBX
+1 NEW OID,VT1,UNT,OSI,OBI,RNG,RST,DA,DIC,DR,DIQ,XTMP,CONT
+2 SET OBI="ICD9"
SET OSI=""
SET MST=$GET(MST)+1
SET OSI=MST
SET CONT=""
+3 SET VTI=$PIECE(HL7,U,2)
if VTI=""
SET VTI="CE"
+4 SET UNT=""
SET RNG=""
SET RST=$GET(^TMP("MCORMN",$JOB,"E",MCOR1,MCOR2,MCOR3,1))
if RST=""
QUIT
+5 ;S DA=$O(^ICD9("B",RST,"")) Q:DA=""
+6 QUIT
+7 SET DIC="^ICD9("
SET DR=".01;3"
SET DIQ="XTMP("
DO EN^DIQ1
+8 SET RST=XTMP(80,DA,.01)_ST(2)_XTMP(80,DA,3)_ST(2)_"ICD9"
+9 DO SETOBX1("",VTI,OBI,OSI,RST)
+10 QUIT
ASTM(TMP,HL7,OBX,MCOR1,MCOR2,MCOR3) ; This is the ASTM message builder for OBX
+1 NEW ASTM,ASTME,VTI,UNT,RNG,RST,OSI,OBI,FILETYPE
+2 SET FILETYPE=$PIECE(TMP,U,2)
SET OSI=""
+3 SET ASTM=$PIECE(HL7,U,1)
SET ASTME=$GET(^MCAR(690.5,ASTM,0))
+4 SET ASTM=$PIECE(ASTME,U,1)_$PIECE(ASTME,U,2)
SET VTI=$PIECE(HL7,U,2)
+5 SET OBI=ASTM_ST(2)_$PIECE(ASTME,U,3)_ST(2)_"CPT4"
+6 SET UNT=$PIECE(HL7,U,3)
SET RNG=$PIECE(HL7,U,4)
+7 DO RDATA(VTI,OBI,OSI,UNT,RNG,FILETYPE,MCOR1,MCOR2,MCOR3)
+8 QUIT
SUM(TMP,HL7,OBX,MCOR1,MCOR2,MCOR3) ; This is the miss. message builder for OBX
+1 NEW FILETYPE,VTI,UNT,RNG,RST,OSI,OBI
+2 SET FILETYPE=$PIECE(TMP,U,2)
SET OSI=""
+3 SET OBI="SST"
SET (UNT,RNG)=""
SET OSI=""
+4 SET VTI="TX"
+5 DO RDATA(VTI,OBI,OSI,UNT,RNG,FILETYPE,MCOR1,MCOR2,MCOR3)
+6 QUIT
DD(TMP,HL7,OBX,MCOR1,MCOR2,MCOR3) ; This is the DD mesage builder for OBX
+1 NEW FLDNAME,VTI,OBI,OSI,UNT,RNG,FILETYPE,FLDNAME
+2 SET FILETYPE=$PIECE(TMP,U,2)
SET FLDNAME=$PIECE(TMP,"^",1)
SET OSI=""
+3 SET VTI=$PIECE(HL7,U,2)
SET OBI=MCOR1_ST(3)_MCOR3_ST(3)_FILETYPE_ST(2)_FLDNAME_ST(2)_"DD"
+4 SET UNT=$PIECE(HL7,U,3)
SET RNG=$PIECE(HL7,U,4)
+5 DO RDATA(VTI,OBI,OSI,UNT,RNG,FILETYPE,MCOR1,MCOR2,MCOR3)
+6 QUIT
OBR(TMP,HL7,OBX,MCOR1,MCOR2,MCOR3) ; This is the OBR add on message
+1 NEW RST,PIECE,FILETYPE
+2 SET FILETYPE=$PIECE(TMP,U,2)
SET RST=$GET(^TMP("MCORMN",$JOB,"E",MCOR1,MCOR2,MCOR3,1))
+3 SET RST=$$CONVERT^MCORMN01(FILETYPE,RST)
SET PIECE=$PIECE(HL7,U,6)+1
+4 SET $PIECE(@MCDEST@(OBX),ST(1),PIECE)=RST
+5 QUIT
RDATA(VTI,OBI,OSI,UNT,RNG,FILETYPE,MCOR1,MCOR2,MCOR3) ;
+1 NEW MCOR4,CONT,LEN,RSTT,TEMP,COUNT,END,RST,CNT,LOOP,LOOP2,X,DIWL,DIWR,DIWF
+2 SET MCOR4=""
+3 FOR LOOP=1:1
SET MCOR4=$ORDER(^TMP("MCORMN",$JOB,"E",MCOR1,MCOR2,MCOR3,MCOR4))
if MCOR4=""
QUIT
Begin DoDot:1
+4 SET X=^TMP("MCORMN",$JOB,"E",MCOR1,MCOR2,MCOR3,MCOR4)
+5 ;I $L(X)>80 D WP
+6 IF $LENGTH(X)>80
Begin DoDot:2
+7 DO WP
End DoDot:2
+8 IF '$TEST
Begin DoDot:2
+9 if LOOP=1
DO SETOBX1(FILETYPE,VTI,OBI,OSI,X)
+10 if LOOP'=1
DO SETNODE(MCDEST,X)
End DoDot:2
End DoDot:1
+11 DO SETOBX2(UNT,RNG)
+12 QUIT
WP ;
+1 KILL ^UTILITY($JOB,"W")
SET DIWL=0
SET DIWR=80
SET DIWF=""
DO ^DIWP
+2 SET CNT=^UTILITY($JOB,"W",0)
+3 FOR LOOP2=1:1:CNT
SET RST=^UTILITY($JOB,"W",0,LOOP2,0)
Begin DoDot:1
+4 IF (LOOP2>1)!(LOOP>1)
DO SETNODE(MCDEST,RST)
+5 IF '$TEST
DO SETOBX1(FILETYPE,VTI,OBI,OSI,RST)
End DoDot:1
+6 KILL ^UTILITY($JOB,"W")
+7 QUIT
SETOBX1(FILETYPE,VTI,OBI,OSI,OBR) ; Sets the first part of QBX line
+1 if VTI=""
SET VTI="ST"
+2 if OSI=""
SET (MSE,OSI)=$GET(MSE)+1
+3 DO SETNODE(MCDEST,$$OBX1^MCORMN01(FILETYPE,VTI,OBI,OSI,OBR))
+4 QUIT
SETOBX2(RNG,UNT) ;Sets the second part of OBX line
+1 SET @MCDEST@(MCLINE,0)=@MCDEST@(MCLINE,0)_$$OBX2^MCORMN01(RNG,UNT)
+2 QUIT
SETNODE(NODE,VALUE) ;Set the node with the HL7 message string
+1 SET MCLINE=MCLINE+1
SET @NODE@(MCLINE,0)=VALUE
+2 QUIT
SLIP(MSTR) ;Seperate the delimiters
+1 FOR LOOP=1:1:5
SET ST(LOOP)=$EXTRACT(MSTR,LOOP,LOOP)
+2 QUIT
