Routine: GMTSMCMA

GMTSMCMA ; WAS/DCB\KER - Medicine 2.2 interface routine      ; 02/11/2003 [11/14/03 9:12am]

 ;;2.7;Health Summary;**4,47,49,61,62,69**;Oct 20, 1995

 ; External Refernces

 ;    DBIA 10064  KILL^XM

 ;    DBIA 10070  ^XMD

 ;    DBIA  1236  $$HL7^MCORMN

 ;    DBIA  3778  HL1^MCORMN

 ;    DBIA 10090  ^DIC(4,

 ;    DBIA 10000  NOW^%DTC

 ;    DBIA 10106  $$HLDATE^HLFNC

 ;    DBIA 10106  $$HLNAME^HLFNC

 ;    DBIA 10017  ^DD("DD")

 ;    DBIA 10106  $$FMDATE^HLFNC

 ;    DBIA 10106  $$FMNAME^HLFNC

 ;    DBIA 10072  REMSBMSG^XMA1C

HSUM(PATID,BDATE,EDATE,OCC,WH,ATYPE) ; Health Summary API

 N ARRAY,MESSAGE,MSH,HLECH,ST,ORD,MSTR,LOOP,MSTR,SAP,SNF,RAP,RNF,MST,PCI,VID

 N REC,LOC,QID,XDEST,WSF,MWDDC,WDC,QRL,BUILDER,LOOP,MESS1,MESS2,TMP,SUB

 N XMDUZ,XMTEXT,XMSUB,XMY,XMZ,XMDUN,GMTSG

 S GMTSG=0 S:$L($T(HL1^MCORMN))>1 GMTSG=1

 S ARRAY="TMP(""HS"",$J)"

 S XMTEXT="TMP(""HS"",$J,"

 S MSTR="|^~\&",HLECH=$E(MSTR,2,4)

 F LOOP=1:1:5 S ST(LOOP)=$E(MSTR,LOOP,LOOP)

 S MESSAGE="TMP",SAP="HEALTH SUMMARY",RAP="MEDICINE",VID=2.1

 S REC=+$O(^DIC(4,"D",DUZ(2),"")),LOC=$P($G(^DIC(4,REC,0)),U,1)

 S (RNF,SNF)=LOC,RAP="Medicine",SAP="Health Summary",MST="HS",PCI="P"

 S @ARRAY@(1,0)=$$MSH(MSTR,SAP,SNF,RAP,RNF,MST,PCI,VID)

 S ATYPE=$S(ATYPE="F":"RD",ATYPE="C":"RD",1:"PG")

 S QRL=$$CONVERT("D",BDATE)_ST(2)_$$CONVERT("D",EDATE)

 S QFC="R",QLR=ATYPE_ST(2)_OCC,WSF=PATID,WDDC=WH

 S @ARRAY@(2,0)=$$QRD(WSF,WDDC,QFC,QLR,QRL)

 I +($G(GMTSG))'>0 D  Q:+ARRY=0

 . S XMSUB="Health Summary Request",XMDUN="HEALTH SUMMARY"

 . S XMY("G.MC MESSAGING SERVER")=""

 . S XMDUZ=".5"

 . D ^XMD I +($G(XMZ))=0 D KILL^XM S ARRY=0 Q

 . S MESS1=XMZ

 . D KILL^XM

 . S ARRY=$$HL7^MCORMN(MESS1) D:+ARRY=0 REMOVE(MESS1,+ARRY)

 I +($G(GMTSG))>0 D  Q:$G(^TMP("MCAR1",$J,1,0))=""

 . D HL1^MCORMN(SAP,PATID,BDATE,EDATE,OCC,ATYPE)

 K ^TMP("MCAR",$J) D:+($G(GMTSG))'>0 SLIT(ARRY)

 ;Below the "0" input to slit is a dummy input in this case

 D:+($G(GMTSG))>0 SLIT(0)

 K ^TMP("MCAR1",$J) D:+($G(GMTSG))'>0 REMOVE(MESS1,ARRY)

SLIT(ARRY) ; Reformat Array

 N LOOP,COUNT,BASE,MCOUNT,BUILDER

 S BUILDER=$S(+($G(GMTSG))'>0:("^XMB(3.9,"_ARRY_",2)"),1:"^TMP(""MCAR1"",$J)")

 S LOOP=0,(MCOUNT,COUNT)=0,SUB=1,BASE="^TMP(""MCAR"",$J)"

 F  S LOOP=$O(@BUILDER@(LOOP)) Q:LOOP=""  D SLITTER

SLITTER ; This will slit the message in a usable form

 N VALUE,ROY,ROUT,LINE

 S VALUE=@BUILDER@(LOOP,0),ROY=$E(VALUE,1,3)

 S ROUT=$S(ROY="MSH":"SMSH",ROY="PID":"SPID",ROY="OBR":"SOBR",ROY="OBX":"SOBX",ROY="MSH":"SMSH",1:"OTHER")

 S LINE="D "_ROUT_"(VALUE)"

 X LINE

SMSH(VALUE) ; Slit the message header

 N PROC,LOOP

 S MSTR=$E(VALUE,4,8),SUB=1

 F LOOP=1:1:5 S ST(LOOP)=$E(MSTR,LOOP,LOOP)

 S MCOUNT=MCOUNT+1,COUNT=1

 S PROC=$P($P(VALUE,ST(1),3),U,1)

 S @BASE@(MCOUNT,COUNT,1)="PROCEDURE"_U_U_PROC

 D SETREF(MCOUNT,COUNT,"PROCEDURE")

SPID(VALUE) ; Slit the PID

 S SUB=1

SOBR(VALUE) ; Slit the OBR

 N TEMP,XDATE

 S TEMP=$$CONVERTA("D",$P(VALUE,ST(1),8))

 S XDATE=TEMP,COUNT=COUNT+1,SUB=1

 S @BASE@(MCOUNT,COUNT,1)="DATE/TIME"_U_U_TEMP

 D SETREF(MCOUNT,COUNT,"DATE/TIME")

 S TEMP=$$CONVERTA("P200",$P(VALUE,ST(1),33))

 I TEMP'="" S COUNT=COUNT+1,@BASE@(MCOUNT,COUNT,1)="PRINCIPAL RESUILT INTERPRETER"_U_U_TEMP D SETREF(MCOUNT,COUNT,"PRINCIPAL RESULT INTERPRETER") S COUNT=COUNT+1

 S TEMP=$$CONVERTA("P200",$P(VALUE,ST(1),34))

 I TEMP'="" S COUNT=COUNT+1,@BASE@(MCOUNT,COUNT,1)="ASSISTANT RESUILT INTERPRETER"_U_U_TEMP  D SETREF(MCOUNT,COUNT,"ASSISTANT RESULT") S COUNT=COUNT+1

 S TEMP=$$CONVERTA("P200",$P(VALUE,ST(1),35))

 I TEMP'="" S COUNT=COUNT+1,@BASE@(MCOUNT,COUNT,1)="TECHNICIAN"_U_U_TEMP  D SETREF(MCOUNT,COUNT,"TECHNICIAN") S COUNT=COUNT+1

SOBX(VALUE) ; Slit the OBX

 N XDES,TEMP,FLDTYPE,UNITS,VAL

 S COUNT=COUNT+1

 S SUB=1,TEMP=$P(VALUE,ST(1),4),XDES=$P(TEMP,ST(2),2)

 S TEMP=$P(TEMP,ST(2),1),FLDTYPE=$P(TEMP,ST(3),3)

 S:FLDTYPE=+FLDTYPE XDES=XDES_";W"

 S VAL=$$CONVERTA(FLDTYPE,$P(VALUE,ST(1),6))

 S UNITS=$P(TEMP,ST(1),7)

 S @BASE@(MCOUNT,COUNT,1)=XDES_U_UNITS_U_VAL

 D SETREF(MCOUNT,COUNT,XDES)

OTHER(VALUE) ; Set the next sub node if the lines continue

 N TEMP,UNITS

 S TEMP=$P(VALUE,ST(1),1),UNITS=$P(VALUE,ST(1),2),SUB=SUB+1

 S @BASE@(MCOUNT,COUNT,SUB)=U_U_TEMP

 S:UNITS'="" $P(@BASE@(MCOUNT,COUNT,1),U,2)=UNITS

MSH(MSTR,SAP,SNF,RAP,RNF,MST,PCI,VID) ; MSH Messaging Line

 N MSH,Y,%,%I

 S MSH="MSH"_MSTR,$P(MSH,ST(1),3)=SAP,$P(MSH,ST(1),4)=SNF

 D NOW^%DTC S $P(MSH,ST(1),8)=$$CONVERT("D",%)

 S $P(MSH,ST(1),5)=RAP,$P(MSH,ST(1),6)=RNF,$P(MSH,ST(1),9)=MST

 S $P(MSH,ST(1),10)=PCI,$P(MSH,ST(1),11)=VID

 Q MSH

QRD(WSF,WDDC,QFC,QLR,QRL) ; QRD Messaging Line

 N QRD,Y,%,%I

 S QRD="QRD"

 D NOW^%DTC S $P(ORD,ST(1),2)=$$CONVERT("D",%)

 S $P(QRD,ST(1),3)=QFC,$P(QRD,ST(1),4)="I"

 S $P(QRD,ST(1),6)=$J,$P(QRD,ST(1),8)=QLR

 S $P(QRD,ST(1),9)=WSF,$P(QRD,ST(1),11)=WDDC,$P(QRD,ST(1),12)=QRL

 Q QRD

CONVERT(FILETYPE,RST) ; Convert FileMan to HL7

 N TEMP

 S TEMP=RST

 S:FILETYPE="D" TEMP=$$HLDATE^HLFNC(RST,"TS")

 S:FILETYPE="P" TEMP=$$HLNAME^HLFNC(RST)

 Q TEMP

CONVERTA(FILETYPE,RST) ; Convert HL7 to FileMan

 N TEMP,Y

 S TEMP=RST

 I FILETYPE["D" S Y=$$FMDATE^HLFNC(RST) X ^DD("DD") S TEMP=Y

 S:(FILETYPE["P200")!(FILETYPE["P690") TEMP=$$FMNAME^HLFNC(RST)

 Q TEMP

REMOVE(MESS1,MESS2) ; Remove messages from the server basket

 N LOOP,XMSER S MESS1=+($G(MESS1)),MESS2=+($G(MESS2))

 F LOOP=MESS1,MESS2 S XMSER="S.MCHL7SERVER" S XMZ=LOOP D:LOOP'=0 REMSBMSG^XMA1C

 D KILL^XM

SETREF(MCOUNT,COUNT,XDES) ; Set Count

 S:XDES'="" @BASE@(MCOUNT,"B",XDES,COUNT)=""

GMTSMCMA  ; WAS/DCB\KER - Medicine 2.2 interface routine      ; 02/11/2003 [11/14/03 9:12am]

 +1       ;;2.7;Health Summary;**4,47,49,61,62,69**;Oct 20, 1995

 +2       ;

 +3       ; External Refernces

 +4       ;    DBIA 10064  KILL^XM

 +5       ;    DBIA 10070  ^XMD

 +6       ;    DBIA  1236  $$HL7^MCORMN

 +7       ;    DBIA  3778  HL1^MCORMN

 +8       ;    DBIA 10090  ^DIC(4,

 +9       ;    DBIA 10000  NOW^%DTC

 +10      ;    DBIA 10106  $$HLDATE^HLFNC

 +11      ;    DBIA 10106  $$HLNAME^HLFNC

 +12      ;    DBIA 10017  ^DD("DD")

 +13      ;    DBIA 10106  $$FMDATE^HLFNC

 +14      ;    DBIA 10106  $$FMNAME^HLFNC

 +15      ;    DBIA 10072  REMSBMSG^XMA1C

 +16      ;

HSUM(PATID,BDATE,EDATE,OCC,WH,ATYPE) ; Health Summary API

 +1        NEW ARRAY,MESSAGE,MSH,HLECH,ST,ORD,MSTR,LOOP,MSTR,SAP,SNF,RAP,RNF,MST,PCI,VID

 +2        NEW REC,LOC,QID,XDEST,WSF,MWDDC,WDC,QRL,BUILDER,LOOP,MESS1,MESS2,TMP,SUB

 +3        NEW XMDUZ,XMTEXT,XMSUB,XMY,XMZ,XMDUN,GMTSG

 +4        SET GMTSG=0

           IF $LENGTH($TEXT(HL1^MCORMN))>1

               SET GMTSG=1

 +5        SET ARRAY="TMP(""HS"",$J)"

 +6        SET XMTEXT="TMP(""HS"",$J,"

 +7        SET MSTR="|^~\&"

           SET HLECH=$EXTRACT(MSTR,2,4)

 +8        FOR LOOP=1:1:5

               SET ST(LOOP)=$EXTRACT(MSTR,LOOP,LOOP)

 +9        SET MESSAGE="TMP"

           SET SAP="HEALTH SUMMARY"

           SET RAP="MEDICINE"

           SET VID=2.1

 +10       SET REC=+$ORDER(^DIC(4,"D",DUZ(2),""))

           SET LOC=$PIECE($GET(^DIC(4,REC,0)),U,1)

 +11       SET (RNF,SNF)=LOC

           SET RAP="Medicine"

           SET SAP="Health Summary"

           SET MST="HS"

           SET PCI="P"

 +12       SET @ARRAY@(1,0)=$$MSH(MSTR,SAP,SNF,RAP,RNF,MST,PCI,VID)

 +13       SET ATYPE=$SELECT(ATYPE="F":"RD",ATYPE="C":"RD",1:"PG")

 +14       SET QRL=$$CONVERT("D",BDATE)_ST(2)_$$CONVERT("D",EDATE)

 +15       SET QFC="R"

           SET QLR=ATYPE_ST(2)_OCC

           SET WSF=PATID

           SET WDDC=WH

 +16       SET @ARRAY@(2,0)=$$QRD(WSF,WDDC,QFC,QLR,QRL)

 +17       IF +($GET(GMTSG))'>0

               Begin DoDot:1

 +18               SET XMSUB="Health Summary Request"

                   SET XMDUN="HEALTH SUMMARY"

 +19               SET XMY("G.MC MESSAGING SERVER")=""

 +20               SET XMDUZ=".5"

 +21               DO ^XMD

                   IF +($GET(XMZ))=0

                       DO KILL^XM

                       SET ARRY=0

                       QUIT

 +22               SET MESS1=XMZ

 +23               DO KILL^XM

 +24               SET ARRY=$$HL7^MCORMN(MESS1)

                   IF +ARRY=0

                       DO REMOVE(MESS1,+ARRY)

               End DoDot:1

               IF +ARRY=0

                   QUIT

 +25       IF +($GET(GMTSG))>0

               Begin DoDot:1

 +26               DO HL1^MCORMN(SAP,PATID,BDATE,EDATE,OCC,ATYPE)

               End DoDot:1

               IF $GET(^TMP("MCAR1",$JOB,1,0))=""

                   QUIT

 +27       KILL ^TMP("MCAR",$JOB)

           IF +($GET(GMTSG))'>0

               DO SLIT(ARRY)

 +28      ;Below the "0" input to slit is a dummy input in this case

 +29       IF +($GET(GMTSG))>0

               DO SLIT(0)

 +30       KILL ^TMP("MCAR1",$JOB)

           IF +($GET(GMTSG))'>0

               DO REMOVE(MESS1,ARRY)

 +31       QUIT

SLIT(ARRY) ; Reformat Array

 +1        NEW LOOP,COUNT,BASE,MCOUNT,BUILDER

 +2        SET BUILDER=$SELECT(+($GET(GMTSG))'>0:("^XMB(3.9,"_ARRY_",2)"),1:"^TMP(""MCAR1"",$J)")

 +3        SET LOOP=0

           SET (MCOUNT,COUNT)=0

           SET SUB=1

           SET BASE="^TMP(""MCAR"",$J)"

 +4        FOR

               SET LOOP=$ORDER(@BUILDER@(LOOP))

               IF LOOP=""

                   QUIT

               DO SLITTER

 +5        QUIT

SLITTER   ; This will slit the message in a usable form

 +1        NEW VALUE,ROY,ROUT,LINE

 +2        SET VALUE=@BUILDER@(LOOP,0)

           SET ROY=$EXTRACT(VALUE,1,3)

 +3        SET ROUT=$SELECT(ROY="MSH":"SMSH",ROY="PID":"SPID",ROY="OBR":"SOBR",ROY="OBX":"SOBX",ROY="MSH":"SMSH",1:"OTHER")

 +4        SET LINE="D "_ROUT_"(VALUE)"

 +5        XECUTE LINE

 +6        QUIT

SMSH(VALUE) ; Slit the message header

 +1        NEW PROC,LOOP

 +2        SET MSTR=$EXTRACT(VALUE,4,8)

           SET SUB=1

 +3        FOR LOOP=1:1:5

               SET ST(LOOP)=$EXTRACT(MSTR,LOOP,LOOP)

 +4        SET MCOUNT=MCOUNT+1

           SET COUNT=1

 +5        SET PROC=$PIECE($PIECE(VALUE,ST(1),3),U,1)

 +6        SET @BASE@(MCOUNT,COUNT,1)="PROCEDURE"_U_U_PROC

 +7        DO SETREF(MCOUNT,COUNT,"PROCEDURE")

 +8        QUIT

SPID(VALUE) ; Slit the PID

 +1        SET SUB=1

 +2        QUIT

SOBR(VALUE) ; Slit the OBR

 +1        NEW TEMP,XDATE

 +2        SET TEMP=$$CONVERTA("D",$PIECE(VALUE,ST(1),8))

 +3        SET XDATE=TEMP

           SET COUNT=COUNT+1

           SET SUB=1

 +4        SET @BASE@(MCOUNT,COUNT,1)="DATE/TIME"_U_U_TEMP

 +5        DO SETREF(MCOUNT,COUNT,"DATE/TIME")

 +6        SET TEMP=$$CONVERTA("P200",$PIECE(VALUE,ST(1),33))

 +7        IF TEMP'=""

               SET COUNT=COUNT+1

               SET @BASE@(MCOUNT,COUNT,1)="PRINCIPAL RESUILT INTERPRETER"_U_U_TEMP

               DO SETREF(MCOUNT,COUNT,"PRINCIPAL RESULT INTERPRETER")

               SET COUNT=COUNT+1

 +8        SET TEMP=$$CONVERTA("P200",$PIECE(VALUE,ST(1),34))

 +9        IF TEMP'=""

               SET COUNT=COUNT+1

               SET @BASE@(MCOUNT,COUNT,1)="ASSISTANT RESUILT INTERPRETER"_U_U_TEMP

               DO SETREF(MCOUNT,COUNT,"ASSISTANT RESULT")

               SET COUNT=COUNT+1

 +10       SET TEMP=$$CONVERTA("P200",$PIECE(VALUE,ST(1),35))

 +11       IF TEMP'=""

               SET COUNT=COUNT+1

               SET @BASE@(MCOUNT,COUNT,1)="TECHNICIAN"_U_U_TEMP

               DO SETREF(MCOUNT,COUNT,"TECHNICIAN")

               SET COUNT=COUNT+1

 +12       QUIT

SOBX(VALUE) ; Slit the OBX

 +1        NEW XDES,TEMP,FLDTYPE,UNITS,VAL

 +2        SET COUNT=COUNT+1

 +3        SET SUB=1

           SET TEMP=$PIECE(VALUE,ST(1),4)

           SET XDES=$PIECE(TEMP,ST(2),2)

 +4        SET TEMP=$PIECE(TEMP,ST(2),1)

           SET FLDTYPE=$PIECE(TEMP,ST(3),3)

 +5        IF FLDTYPE=+FLDTYPE

               SET XDES=XDES_";W"

 +6        SET VAL=$$CONVERTA(FLDTYPE,$PIECE(VALUE,ST(1),6))

 +7        SET UNITS=$PIECE(TEMP,ST(1),7)

 +8        SET @BASE@(MCOUNT,COUNT,1)=XDES_U_UNITS_U_VAL

 +9        DO SETREF(MCOUNT,COUNT,XDES)

 +10       QUIT

OTHER(VALUE) ; Set the next sub node if the lines continue

 +1        NEW TEMP,UNITS

 +2        SET TEMP=$PIECE(VALUE,ST(1),1)

           SET UNITS=$PIECE(VALUE,ST(1),2)

           SET SUB=SUB+1

 +3        SET @BASE@(MCOUNT,COUNT,SUB)=U_U_TEMP

 +4        IF UNITS'=""

               SET $PIECE(@BASE@(MCOUNT,COUNT,1),U,2)=UNITS

 +5        QUIT

MSH(MSTR,SAP,SNF,RAP,RNF,MST,PCI,VID) ; MSH Messaging Line

 +1        NEW MSH,Y,%,%I

 +2        SET MSH="MSH"_MSTR

           SET $PIECE(MSH,ST(1),3)=SAP

           SET $PIECE(MSH,ST(1),4)=SNF

 +3        DO NOW^%DTC

           SET $PIECE(MSH,ST(1),8)=$$CONVERT("D",%)

 +4        SET $PIECE(MSH,ST(1),5)=RAP

           SET $PIECE(MSH,ST(1),6)=RNF

           SET $PIECE(MSH,ST(1),9)=MST

 +5        SET $PIECE(MSH,ST(1),10)=PCI

           SET $PIECE(MSH,ST(1),11)=VID

 +6        QUIT MSH

QRD(WSF,WDDC,QFC,QLR,QRL) ; QRD Messaging Line

 +1        NEW QRD,Y,%,%I

 +2        SET QRD="QRD"

 +3        DO NOW^%DTC

           SET $PIECE(ORD,ST(1),2)=$$CONVERT("D",%)

 +4        SET $PIECE(QRD,ST(1),3)=QFC

           SET $PIECE(QRD,ST(1),4)="I"

 +5        SET $PIECE(QRD,ST(1),6)=$JOB

           SET $PIECE(QRD,ST(1),8)=QLR

 +6        SET $PIECE(QRD,ST(1),9)=WSF

           SET $PIECE(QRD,ST(1),11)=WDDC

           SET $PIECE(QRD,ST(1),12)=QRL

 +7        QUIT QRD

CONVERT(FILETYPE,RST) ; Convert FileMan to HL7

 +1        NEW TEMP

 +2        SET TEMP=RST

 +3        IF FILETYPE="D"

               SET TEMP=$$HLDATE^HLFNC(RST,"TS")

 +4        IF FILETYPE="P"

               SET TEMP=$$HLNAME^HLFNC(RST)

 +5        QUIT TEMP

CONVERTA(FILETYPE,RST) ; Convert HL7 to FileMan

 +1        NEW TEMP,Y

 +2        SET TEMP=RST

 +3        IF FILETYPE["D"

               SET Y=$$FMDATE^HLFNC(RST)

               XECUTE ^DD("DD")

               SET TEMP=Y

 +4        IF (FILETYPE["P200")!(FILETYPE["P690")

               SET TEMP=$$FMNAME^HLFNC(RST)

 +5        QUIT TEMP

REMOVE(MESS1,MESS2) ; Remove messages from the server basket

 +1        NEW LOOP,XMSER

           SET MESS1=+($GET(MESS1))

           SET MESS2=+($GET(MESS2))

 +2        FOR LOOP=MESS1,MESS2

               SET XMSER="S.MCHL7SERVER"

               SET XMZ=LOOP

               IF LOOP'=0

                   DO REMSBMSG^XMA1C

 +3        DO KILL^XM

 +4        QUIT

SETREF(MCOUNT,COUNT,XDES) ; Set Count

 +1        IF XDES'=""

               SET @BASE@(MCOUNT,"B",XDES,COUNT)=""

 +2        QUIT

GMTSMCMA.m