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)
Q
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
Q
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
Q
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")
Q
SPID(VALUE) ; Slit the PID
S SUB=1
Q
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
Q
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)
Q
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
Q
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
Q
SETREF(MCOUNT,COUNT,XDES) ; Set Count
S:XDES'="" @BASE@(MCOUNT,"B",XDES,COUNT)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSMCMA 5579 printed Sep 23, 2025@19:34:10 Page 2
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
