MCORMN ;WISC/DCB-Front-end for Health Summary ;4/26/04 11:54
;;1.0;CLINICAL PROCEDURES;**5,13**;Apr 01, 2004;Build 19
; Reference IA #1236 for Medicine and Health Summary interface.
; #3778 for Medicine and Health Summary interface for RDV
; #10070 for XMD API call.
; #10064 for XM call.
; #10090 DIC(4) Read Access.
; #10106 for HLFNC calls.
; #10113 for Access to ^XMB(3.9,#,2)
HL7(MESSNUMB) ;This is the HL7 entry point for queries
N MSH,TEMP,ORD,ST,MSTR,BDATE,EDATE,OCC,PROC,PATID,MCTDEC,XMZ,MCLINE
N QDT,QFC,QP,QID,RAP,GNODE,ATYPE
Q:+MESSNUMB=0 0
S GNODE="^XMB(3.9,"_MESSNUMB_",2)"
S MSH=$G(@GNODE@(1,0)) I MSH="" D ERROR Q 0
S MSTR=$E(MSH,4,9) D SLIP^MCORMN0(MSTR)
S QRD=$G(@GNODE@(2,0)) I QRD="" D ERROR Q 0
S QFC=$P(QRD,ST(1),3) I QFC'="R" D ERROR Q 0
S QLR=$P(QRD,ST(1),8),OCC=$P(QLR,ST(2),2),ATYPE=$P(QLR,ST(2),1)
S PATID=+$P(QRD,ST(1),9)
I '$D(^MCAR(690,"AC",PATID)) D ERROR Q ""
S PROC=$P(QRD,ST(1),11)
S TEMP=$P(QRD,ST(1),12) S BDATE=$P(TEMP,ST(2),1),EDATE=$P(TEMP,ST(2),2)
S BDATE=$$FMDATE^HLFNC(BDATE),EDATE=$$FMDATE^HLFNC(EDATE)
S RAP=$P(MSH,ST(1),3)
S MCTDEC="^TMP(""MCAR1"",$J)",GLOBAL=1
D HSUM(RAP,PATID,BDATE,EDATE,OCC,PROC,MSTR,MCTDEC,.GLOBAL,ATYPE)
I GLOBAL=0 S ^TMP("MCAR1",$J,1)="" Q 0
I GLOBAL'=0 D
.S XMSUB="Medicine Response",XMDUN="Medicine",XMDUZ=.5
.S XMTEXT="^TMP(""MCAR1"",$J,",XMY("G.MC MESSAGING SERVER")=""
.;S XMY(DUZ)=""
.D ^XMD
.S GLOBAL=+$G(XMZ)
D KILL^XM
K ^TMP("MCAR1",$J)
Q GLOBAL
ERROR ;HL7 Messaging Error
D KILL^XM Q
SERVER ;A do nothing routine
Q
HSUM(RAP,PATID,BDATE,EDATE,OCC,PE,MSTR,MCTDEC,GLOBAL,ATYPE) ;Sending Message Builder
N LOC,REC,RNF,SNF,SAP,MST,PCI,VID,MCDFN,TMP,ENDDATE,BEGDATE,MCIMAGE
N LOOP,DFN,COUNT,MCPROC,MCFILE,PREC,SENDATE,FILE,MCREC,MCDEST
N MCER,MCERR,MCVAL,TEMP,WH,S5
I +PATID'=PATID S GLOBAL=0 Q
I '$D(^MCAR(690,"AC",PATID))&('$D(^MDD(702,"B",PATID))) S GLOBAL=0 Q
I PE'="" D
.S S5=+$O(^MCAR(697.2,"B",PE,0))
.S S5=$P($G(^MCAR(697.2,S5,0)),U,2)
.I S5="" S PE="" K S5
S MCVAL=DUZ(2),REC=$$FIND1^DIC(4,"","X",MCVAL,"D","","MCER")
S LOC=$S(+REC:$$GET1^DIQ(4,+REC_",",.01),1:"")
S (RNF,SNF)=LOC
S SAP="Medicine",MST="HS",PCI="P"
S VID=$P($T(+2),";",3),MCDFN=PATID,MCLINE=0
S:EDATE="" EDATE=9999999.9999
S:BDATE="" BDATE=0
S:+OCC=0 OCC=999999
I EDATE<BDATE S TEMP=EDATE,EDATE=BDATE,BDATE=TEMP
S ENDDATE=(9999999.9999-EDATE)-.00001
S BEGDATE=(9999999.9999-BDATE)+.00001
S LOOP=ENDDATE,COUNT=0
N L,LL,LL1,K,M,PE,REC,S1,S2,S4,S6
N MCARCODE,MCARFILE,MCARPSUM,MCARSUM,MCESKEY,MCESON,MCSUP,MCESSEC
S MCIMAGE=""
K ^TMP("MCAR",$J)
S DFN=PATID,WH="P" D ^MCARPS1
PROCN ;
N MCRESULT,MDHOLDR,MCROU
I $$PATCH^XPDUTL("MD*1.0*2")!('$$FIND1^DIC(9.4,"","MX","MEDICINE")) D
.S MDRDV=1 K ^TMP("MDPLST",$J)
.S MCRESULT=$NA(^TMP("MDPLST",$J)) N MCLP,MCLP1,MCXG
.S MCROU="D GET702^MDPS3(.MCRESULT,PATID,"""",BDATE,EDATE,OCC)"
.X MCROU
.S MCLP="" F S MCLP=$O(^TMP("MDPLST",$J,MCLP)) Q:MCLP="" S MCLP1="" F S MCLP1=$O(^TMP("MDPLST",$J,MCLP,MCLP1)) Q:MCLP1="" S MCXG=$G(^(MCLP1)) D
..S:$G(^TMP("MCAR",$J,MCLP,MCLP1))="" ^TMP("MCAR",$J,MCLP,MCLP1)=MCXG
.K ^TMP("MDPLST",$J)
S MCPROC="",COUNT=0 N MCG
F S MCPROC=$O(^TMP("MCAR",$J,MCPROC)) Q:MCPROC="" D
.S MCDTIME=ENDDATE
.F S MCDTIME=$O(^TMP("MCAR",$J,MCPROC,MCDTIME)) Q:MCDTIME="" Q:COUNT'<OCC Q:MCDTIME>BEGDATE S MCG=$G(^(MCDTIME)) D
..S MCREC=$P(MCG,U,2) Q:+MCREC=0
..S MCDEST=MCTDEC,SENDATE=9999999.9999-MCDTIME,MDHOLDR=MCPROC
..I +$G(BDATE) Q:SENDATE<+$G(BDATE)
..I +$G(EDATE) Q:SENDATE>+$G(EDATE)
..I $P(MCG,U,4)["MDPS1" S MCARGDA=+$P(MCG,U,2) Q:'MCARGDA D PR690 S COUNT=COUNT+1,MCPROC=MDHOLDR Q
..I $P(MCG,U,4)["MDPS4" S MCARGDA=+$P(MCG,U,2) Q:'MCARGDA D PR690 S COUNT=COUNT+1,MCPROC=MDHOLDR Q
..S PREC=$O(^MCAR(697.2,"B",MCPROC,"")) Q:PREC=""
..S FILE=$P($G(^MCAR(697.2,PREC,0)),U,2) Q:FILE=""
..S MCFILE=+$P(FILE,"MCAR(",2)
..S MCERR=$$BUILD^MCORMN0(RAP,DFN,SAP,SNF,RNF,MST,PCI,VID,.MCLINE,MSTR,MCDEST,MCPROC,MCFILE,MCREC,SENDATE,ATYPE)
..S:MCERR=0 COUNT=COUNT+1
K ^TMP("MCAR",$J),^TMP("MDPTXT",$J),MCPRO,MCARPPS,MCARGRTN,MDT,MDHDR,MDRDV
Q
PR690 ; Set node for CP Reports
N HLECH,MCRREC,ST
S MCPRO=$P(MCG,U,11),MCARPPS=$P(MCG,U,3,4),MCARGRTN=$P(MCG,U,5),MDT="RD",MDHDR=1
S HLECH=$E(MSTR,2,4) D SLIP^MCORMN0(MSTR)
D SETNODE(MCDEST,$$MSH^MCORMN01(MCPROC,SAP,SNF,RAP,RNF,MST,PCI,VID))
D SETNODE(MCDEST,$$PID^MCORMN01(MCDFN))
D SETNODE(MCDEST,$$OBR1(SENDATE,MCPROC,HLECH))
D SETNODE(MCDEST,$$OBX1^MCORMN01("W","ST","702~.1~702.1^^DD",1,""))
D @MCARPPS S MCRREC=$NA(^TMP("MDPTXT",$J))
F S MCRREC=$Q(@MCRREC) Q:MCRREC="" Q:$QS(MCRREC,1)'="MDPTXT" D
.D SETNODE(MCTDEC,$G(@MCRREC))
D SETNODE(MCDEST,"||")
Q
OBR1(SDATE,MCPROC,HLECH) ; OBX Messaging Line
N LOOP,TEMP,TMP,STAT,STR
S TMP="OTH"
S STAT="COMPLETE"
S TEMP=$$CONVERT^MCORMN01("D",SDATE),STR="OBR",$P(STR,ST(1),8)=TEMP
S $P(STR,ST(1),16)=TMP,$P(STR,ST(1),26)=STAT
Q STR
SETNODE(NODE,VALUE) ; Set the node with the HL7 message string
S MCLINE=MCLINE+1,@NODE@(MCLINE,0)=VALUE
Q
HL1(MCSAP,MCDFN,MCB,MCE,MCOCC,MCTYP) ; Alternate Entry Point for Data View
N MSH,TEMP,ORD,ST,MSTR,BDATE,EDATE,OCC,PROC,PATID,MCTDEC,XMZ,MCLINE
N QDT,QFC,QP,QID,RAP,GNODE,ATYPE
S GLOBAL=1 K ^TMP("MCAR1",$J)
D HSUM(MCSAP,MCDFN,MCB,MCE,MCOCC,"","|^~\&|","^TMP(""MCAR1"",$J)",.GLOBAL,MCTYP)
I GLOBAL=0 S ^TMP("MCAR1",$J,1,0)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCORMN 5485 printed Sep 23, 2025@19:52:08 Page 2
MCORMN ;WISC/DCB-Front-end for Health Summary ;4/26/04 11:54
+1 ;;1.0;CLINICAL PROCEDURES;**5,13**;Apr 01, 2004;Build 19
+2 ; Reference IA #1236 for Medicine and Health Summary interface.
+3 ; #3778 for Medicine and Health Summary interface for RDV
+4 ; #10070 for XMD API call.
+5 ; #10064 for XM call.
+6 ; #10090 DIC(4) Read Access.
+7 ; #10106 for HLFNC calls.
+8 ; #10113 for Access to ^XMB(3.9,#,2)
HL7(MESSNUMB) ;This is the HL7 entry point for queries
+1 NEW MSH,TEMP,ORD,ST,MSTR,BDATE,EDATE,OCC,PROC,PATID,MCTDEC,XMZ,MCLINE
+2 NEW QDT,QFC,QP,QID,RAP,GNODE,ATYPE
+3 if +MESSNUMB=0
QUIT 0
+4 SET GNODE="^XMB(3.9,"_MESSNUMB_",2)"
+5 SET MSH=$GET(@GNODE@(1,0))
IF MSH=""
DO ERROR
QUIT 0
+6 SET MSTR=$EXTRACT(MSH,4,9)
DO SLIP^MCORMN0(MSTR)
+7 SET QRD=$GET(@GNODE@(2,0))
IF QRD=""
DO ERROR
QUIT 0
+8 SET QFC=$PIECE(QRD,ST(1),3)
IF QFC'="R"
DO ERROR
QUIT 0
+9 SET QLR=$PIECE(QRD,ST(1),8)
SET OCC=$PIECE(QLR,ST(2),2)
SET ATYPE=$PIECE(QLR,ST(2),1)
+10 SET PATID=+$PIECE(QRD,ST(1),9)
+11 IF '$DATA(^MCAR(690,"AC",PATID))
DO ERROR
QUIT ""
+12 SET PROC=$PIECE(QRD,ST(1),11)
+13 SET TEMP=$PIECE(QRD,ST(1),12)
SET BDATE=$PIECE(TEMP,ST(2),1)
SET EDATE=$PIECE(TEMP,ST(2),2)
+14 SET BDATE=$$FMDATE^HLFNC(BDATE)
SET EDATE=$$FMDATE^HLFNC(EDATE)
+15 SET RAP=$PIECE(MSH,ST(1),3)
+16 SET MCTDEC="^TMP(""MCAR1"",$J)"
SET GLOBAL=1
+17 DO HSUM(RAP,PATID,BDATE,EDATE,OCC,PROC,MSTR,MCTDEC,.GLOBAL,ATYPE)
+18 IF GLOBAL=0
SET ^TMP("MCAR1",$JOB,1)=""
QUIT 0
+19 IF GLOBAL'=0
Begin DoDot:1
+20 SET XMSUB="Medicine Response"
SET XMDUN="Medicine"
SET XMDUZ=.5
+21 SET XMTEXT="^TMP(""MCAR1"",$J,"
SET XMY("G.MC MESSAGING SERVER")=""
+22 ;S XMY(DUZ)=""
+23 DO ^XMD
+24 SET GLOBAL=+$GET(XMZ)
End DoDot:1
+25 DO KILL^XM
+26 KILL ^TMP("MCAR1",$JOB)
+27 QUIT GLOBAL
ERROR ;HL7 Messaging Error
+1 DO KILL^XM
QUIT
SERVER ;A do nothing routine
+1 QUIT
HSUM(RAP,PATID,BDATE,EDATE,OCC,PE,MSTR,MCTDEC,GLOBAL,ATYPE) ;Sending Message Builder
+1 NEW LOC,REC,RNF,SNF,SAP,MST,PCI,VID,MCDFN,TMP,ENDDATE,BEGDATE,MCIMAGE
+2 NEW LOOP,DFN,COUNT,MCPROC,MCFILE,PREC,SENDATE,FILE,MCREC,MCDEST
+3 NEW MCER,MCERR,MCVAL,TEMP,WH,S5
+4 IF +PATID'=PATID
SET GLOBAL=0
QUIT
+5 IF '$DATA(^MCAR(690,"AC",PATID))&('$DATA(^MDD(702,"B",PATID)))
SET GLOBAL=0
QUIT
+6 IF PE'=""
Begin DoDot:1
+7 SET S5=+$ORDER(^MCAR(697.2,"B",PE,0))
+8 SET S5=$PIECE($GET(^MCAR(697.2,S5,0)),U,2)
+9 IF S5=""
SET PE=""
KILL S5
End DoDot:1
+10 SET MCVAL=DUZ(2)
SET REC=$$FIND1^DIC(4,"","X",MCVAL,"D","","MCER")
+11 SET LOC=$SELECT(+REC:$$GET1^DIQ(4,+REC_",",.01),1:"")
+12 SET (RNF,SNF)=LOC
+13 SET SAP="Medicine"
SET MST="HS"
SET PCI="P"
+14 SET VID=$PIECE($TEXT(+2),";",3)
SET MCDFN=PATID
SET MCLINE=0
+15 if EDATE=""
SET EDATE=9999999.9999
+16 if BDATE=""
SET BDATE=0
+17 if +OCC=0
SET OCC=999999
+18 IF EDATE<BDATE
SET TEMP=EDATE
SET EDATE=BDATE
SET BDATE=TEMP
+19 SET ENDDATE=(9999999.9999-EDATE)-.00001
+20 SET BEGDATE=(9999999.9999-BDATE)+.00001
+21 SET LOOP=ENDDATE
SET COUNT=0
+22 NEW L,LL,LL1,K,M,PE,REC,S1,S2,S4,S6
+23 NEW MCARCODE,MCARFILE,MCARPSUM,MCARSUM,MCESKEY,MCESON,MCSUP,MCESSEC
+24 SET MCIMAGE=""
+25 KILL ^TMP("MCAR",$JOB)
+26 SET DFN=PATID
SET WH="P"
DO ^MCARPS1
PROCN ;
+1 NEW MCRESULT,MDHOLDR,MCROU
+2 IF $$PATCH^XPDUTL("MD*1.0*2")!('$$FIND1^DIC(9.4,"","MX","MEDICINE"))
Begin DoDot:1
+3 SET MDRDV=1
KILL ^TMP("MDPLST",$JOB)
+4 SET MCRESULT=$NAME(^TMP("MDPLST",$JOB))
NEW MCLP,MCLP1,MCXG
+5 SET MCROU="D GET702^MDPS3(.MCRESULT,PATID,"""",BDATE,EDATE,OCC)"
+6 XECUTE MCROU
+7 SET MCLP=""
FOR
SET MCLP=$ORDER(^TMP("MDPLST",$JOB,MCLP))
if MCLP=""
QUIT
SET MCLP1=""
FOR
SET MCLP1=$ORDER(^TMP("MDPLST",$JOB,MCLP,MCLP1))
if MCLP1=""
QUIT
SET MCXG=$GET(^(MCLP1))
Begin DoDot:2
+8 if $GET(^TMP("MCAR",$JOB,MCLP,MCLP1))=""
SET ^TMP("MCAR",$JOB,MCLP,MCLP1)=MCXG
End DoDot:2
+9 KILL ^TMP("MDPLST",$JOB)
End DoDot:1
+10 SET MCPROC=""
SET COUNT=0
NEW MCG
+11 FOR
SET MCPROC=$ORDER(^TMP("MCAR",$JOB,MCPROC))
if MCPROC=""
QUIT
Begin DoDot:1
+12 SET MCDTIME=ENDDATE
+13 FOR
SET MCDTIME=$ORDER(^TMP("MCAR",$JOB,MCPROC,MCDTIME))
if MCDTIME=""
QUIT
if COUNT'<OCC
QUIT
if MCDTIME>BEGDATE
QUIT
SET MCG=$GET(^(MCDTIME))
Begin DoDot:2
+14 SET MCREC=$PIECE(MCG,U,2)
if +MCREC=0
QUIT
+15 SET MCDEST=MCTDEC
SET SENDATE=9999999.9999-MCDTIME
SET MDHOLDR=MCPROC
+16 IF +$GET(BDATE)
if SENDATE<+$GET(BDATE)
QUIT
+17 IF +$GET(EDATE)
if SENDATE>+$GET(EDATE)
QUIT
+18 IF $PIECE(MCG,U,4)["MDPS1"
SET MCARGDA=+$PIECE(MCG,U,2)
if 'MCARGDA
QUIT
DO PR690
SET COUNT=COUNT+1
SET MCPROC=MDHOLDR
QUIT
+19 IF $PIECE(MCG,U,4)["MDPS4"
SET MCARGDA=+$PIECE(MCG,U,2)
if 'MCARGDA
QUIT
DO PR690
SET COUNT=COUNT+1
SET MCPROC=MDHOLDR
QUIT
+20 SET PREC=$ORDER(^MCAR(697.2,"B",MCPROC,""))
if PREC=""
QUIT
+21 SET FILE=$PIECE($GET(^MCAR(697.2,PREC,0)),U,2)
if FILE=""
QUIT
+22 SET MCFILE=+$PIECE(FILE,"MCAR(",2)
+23 SET MCERR=$$BUILD^MCORMN0(RAP,DFN,SAP,SNF,RNF,MST,PCI,VID,.MCLINE,MSTR,MCDEST,MCPROC,MCFILE,MCREC,SENDATE,ATYPE)
+24 if MCERR=0
SET COUNT=COUNT+1
End DoDot:2
End DoDot:1
+25 KILL ^TMP("MCAR",$JOB),^TMP("MDPTXT",$JOB),MCPRO,MCARPPS,MCARGRTN,MDT,MDHDR,MDRDV
+26 QUIT
PR690 ; Set node for CP Reports
+1 NEW HLECH,MCRREC,ST
+2 SET MCPRO=$PIECE(MCG,U,11)
SET MCARPPS=$PIECE(MCG,U,3,4)
SET MCARGRTN=$PIECE(MCG,U,5)
SET MDT="RD"
SET MDHDR=1
+3 SET HLECH=$EXTRACT(MSTR,2,4)
DO SLIP^MCORMN0(MSTR)
+4 DO SETNODE(MCDEST,$$MSH^MCORMN01(MCPROC,SAP,SNF,RAP,RNF,MST,PCI,VID))
+5 DO SETNODE(MCDEST,$$PID^MCORMN01(MCDFN))
+6 DO SETNODE(MCDEST,$$OBR1(SENDATE,MCPROC,HLECH))
+7 DO SETNODE(MCDEST,$$OBX1^MCORMN01("W","ST","702~.1~702.1^^DD",1,""))
+8 DO @MCARPPS
SET MCRREC=$NAME(^TMP("MDPTXT",$JOB))
+9 FOR
SET MCRREC=$QUERY(@MCRREC)
if MCRREC=""
QUIT
if $QSUBSCRIPT(MCRREC,1)'="MDPTXT"
QUIT
Begin DoDot:1
+10 DO SETNODE(MCTDEC,$GET(@MCRREC))
End DoDot:1
+11 DO SETNODE(MCDEST,"||")
+12 QUIT
OBR1(SDATE,MCPROC,HLECH) ; OBX Messaging Line
+1 NEW LOOP,TEMP,TMP,STAT,STR
+2 SET TMP="OTH"
+3 SET STAT="COMPLETE"
+4 SET TEMP=$$CONVERT^MCORMN01("D",SDATE)
SET STR="OBR"
SET $PIECE(STR,ST(1),8)=TEMP
+5 SET $PIECE(STR,ST(1),16)=TMP
SET $PIECE(STR,ST(1),26)=STAT
+6 QUIT STR
SETNODE(NODE,VALUE) ; Set the node with the HL7 message string
+1 SET MCLINE=MCLINE+1
SET @NODE@(MCLINE,0)=VALUE
+2 QUIT
HL1(MCSAP,MCDFN,MCB,MCE,MCOCC,MCTYP) ; Alternate Entry Point for Data View
+1 NEW MSH,TEMP,ORD,ST,MSTR,BDATE,EDATE,OCC,PROC,PATID,MCTDEC,XMZ,MCLINE
+2 NEW QDT,QFC,QP,QID,RAP,GNODE,ATYPE
+3 SET GLOBAL=1
KILL ^TMP("MCAR1",$JOB)
+4 DO HSUM(MCSAP,MCDFN,MCB,MCE,MCOCC,"","|^~\&|","^TMP(""MCAR1"",$J)",.GLOBAL,MCTYP)
+5 IF GLOBAL=0
SET ^TMP("MCAR1",$JOB,1,0)=""
+6 QUIT
