Routine: MCORMN

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

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

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,"||")

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

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)=""

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCORMN   5485     printed  Mar 13, 2025@21:20:47                                                                                                                                                                                                      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

MCORMN.m