MDHL7U2 ; HOIFO/WAA -Utilities for CP PROCESSING OBX text ; 7/26/00
;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004
; Supported IA #2263 for XPAR parameter calls.
; Supported IA #3006 for XMXAPIG calls.
; Supported IA #10106 for HL7 calls.
;
GET123(MDD702) ; return the IEN for an entry in 123 based on the 702
; This subroutine will return -1 if no entry is found
N CONSULT
S CONSULT=-1
I $G(^MDD(702,MDD702,0))'="" D ; Entry in 702 does exist
. S CONSULT=$$GET1^DIQ(702,MDD702,.05,"I") ; Grab pointer to consults
. I CONSULT'>0 S CONSULT=-1 Q ; Bad consult
. Q
Q CONSULT
GETREF(CONSULT) ; Return the physician and pointer to 200
; in the format pointer200^last^first
N NREF,REF,PHY
S PHY=-1
S REF=$$GET1^DIQ(123,CONSULT,10,"I") D
. Q:REF=""
. S NREF=$$GET1^DIQ(123,CONSULT,10,"E") Q:NREF=""
. S NREF=$$HLNAME^HLFNC(NREF,"^~\&")
. S PHY=REF_"^"_NREF
. Q
Q PHY
;
MG(MG) ; This function is to validate that a mailgroup
; and that there is someone in it
;
; Input:
; MG the Mailgroup IEN in the file
;
; Output:
; 1 = Valid mail group with people in it
; 0 = Invalid group with No people in it
;
N X,MGU
S X=0 I '$G(MG) Q X
S MGU=$$GET1^DIQ(3.8,+MG_",",.01)
I MGU'="" D
. I $$GOTLOCAL^XMXAPIG(MGU) S X=1
. Q
Q X
INST(DEV,X) ; Process Device and determine if the device Functioning
; DEV = Name of the device from the .01 field
; X = 1 is true that the device cleared to process
; 0 is false the device is not allowed to process
; X(0) = The device name^IEN^Print name if one^
; Processing routine^Routine Checksum^Patch Level
; X(I) = The reasons why it is OR is not allowed to process
N LINE,I,J,Y
S I=0
S X=0
I DEV'?1N.N S DEV=$O(^MDS(702.09,"B",DEV,0)) I DEV<1 S DEV=0
S LINE=$G(^MDS(702.09,DEV,0))
S X(I)=$S($P(LINE,U)'="":$P(LINE,U),1:"UNKNOWN")_U_DEV_U_$S($P(LINE,U)'="":$P(LINE,U,6),1:"Device Unknown")
I LINE="" S I=I+1,X(I)="No Device Found." Q
I $P(LINE,U,6)="" S I=I+1,X(I)="No Print Name Defined."
I $P(LINE,U,9)="" S I=I+1,X(I)="Active switch is not set for this device."
I $P(LINE,U,9)'=1 S I=I+1,X(I)="Device is set to Inactive."
I $P(LINE,U,2)="" S I=I+1,X(I)="No Mail Group Defined in the instrument file."
E D
. Q:$$MG^MDHL7U2($P(LINE,U,2))
. N MGU
. I $$FIND1^DIC(3.8,"","BX","MD DEVICE ERRORS")'=+$P(LINE,U,2) S I=I+1,X(I)="No Mail Group Defined in VISTA." Q
. S MGU=$$GET1^DIQ(3.8,+$P(LINE,U,2)_",",.01)
. I '$$GOTLOCAL^XMXAPIG(MGU) S I=I+1,X(I)="No User are defined in the "_MGU_" Mail Group."
. Q
S LINE=$G(^MDS(702.09,DEV,.1))
I $P(LINE,U,1)="" S I=I+1,X(I)="No Processing routine indicated."
E D
. N ROU,ROUTINE
. S ROUTINE=$P(LINE,U,1)
. S ROU=$$VALRTN^MDHL7U2($P(LINE,U,1))
. I 'ROU S I=I+1,X(I)="Processing routine does not exist."
. E D ; Plug in the needed information about the routine
. . N LINE,SCND,HOLD
. . S LINE=X(0)
. . S $P(LINE,U,4)=ROU ; processing routine
. . S X(0)=LINE
. . I $E(ROUTINE,1,2)="MD" Q
. . I $E(ROUTINE,1,2)="MC" Q
. . S X(10)=" ***WARNING***"
. . S X(11)=" This will not stop the processing of instrument."
. . S X(12)=" Processing routine "_ROUTINE_" is not in CP Namespace."
. . S X(13)=" "
. . S X(14)=" ***WARNING***"
. . Q
. Q
I $P(LINE,U,2)="" S I=I+1,X(I)="No Package Code."
I $P(LINE,U,2)'="M" D
. N J,VLD
. S VLD=0
. I $P(LINE,U,3) D
. . I $P(LINE,U,6)="" S I=I+1,X(I)="No HL7 Instrument ID."
. . I '$P(LINE,U,8) S I=I+1,X(I)="No HL7 Link."
. . Q
. S LINE=$G(^MDS(702.09,DEV,.3))
. F J=1:1:7 S VLD=$P(LINE,U,J) I VLD Q
. I 'VLD S I=I+1,X(I)="No Valid Attachment Types indicated."
. Q
I $$GET^XPAR("SYS","MD IMAGING XFER")="" S I=I+1,X(I)="No Imaging Share indicated in the Systems Parameters"
I I=0 S X="1",X(1)="Cleared to Process HL7 Messages"
Q
VALRTN(RTN) ; Function to check Validity
N X
S X=RTN X ^%ZOSF("TEST") S X=$T
Q X
TEXT ;;PROCESS TEXT;.302
N CNT,LN,DEL
S SEP=$G(SEP,"^")
S CNT=0,LN=0,DEL=0
S MDDZ=$$UPDATE^MDHL7U(MDIEN) ; Create the entry in the multi.
Q:'MDDZ
S ^MDD(703.1,MDIEN,.1,MDDZ,0)=$P(MDATT(PROC),";",6)
S ^MDD(703.1,MDIEN,.1,MDDZ,.2,0)="^^"_LN_"^"_LN_"^"_DT_"^"
F S CNT=$O(^TMP($J,"MDHL7","TEXT",CNT)) Q:CNT<1 D
. N LINE
. S LINE=$G(^TMP($J,"MDHL7","TEXT",CNT)) Q:LINE=""
. I $P(LINE,"|",1)'="OBX" Q
. I $S($P(LINE,"|",3)="TX":0,$P(LINE,"|",3)="FT":0,1:1) Q
. I $E($P(LINE,"|",6),1,2)="\\" Q
. I $E($P(LINE,"|",6),1,2)="//" Q
. ; ^-- Quit if the line is not a text line or a freetext line.
. S TEXT=$P(LINE,"|",6) Q:TEXT=""
. I $D(^TMP($J,"MDHL7","TEXT",CNT))=11 D Q
. . ; Process the first line then go move on the the sub line
. . D PROCESS(.TEXT)
. . N CNT2
. . S CNT2=0
. . F S CNT2=$O(^TMP($J,"MDHL7","TEXT",CNT,CNT2)) Q:CNT2<1 D
. . . N MSG1
. . . S MSG1=^TMP($J,"MDHL7","TEXT",CNT,CNT2)
. . . ; get the next message continution
. . . S TEXT=TEXT_$P(MSG1,SEP)
. . . D SAVE(TEXT)
. . . S TEXT=$P(MSG1,SEP,2,($L(MSG1,SEP)))
. . . D PROCESS(.TEXT)
. . . Q
. . I TEXT'="" S:TEXT["|" TEXT=$P(TEXT,"|") D SAVE(TEXT)
. . Q
. E D SAVE(TEXT)
. Q
S ^MDD(703.1,MDIEN,.1,MDDZ,.2,0)="^^"_LN_"^"_LN_"^"_DT_"^"
Q
SAVE(TEXT) ; Save the data to the file 703.1
S LN=LN+1
S TEXT=$P(TEXT,SEP)
S ^MDD(703.1,MDIEN,.1,MDDZ,.2,LN,0)=TEXT
Q
PROCESS(TEXT) ; Long lines
N I,LN2,DEL
S DEL=$L(TEXT,SEP)
I DEL'>1 D Q
. D SAVE(TEXT)
. S TEXT=""
F I=1:1:(DEL-1) D
. S LN2=$P(TEXT,SEP,I)
. D SAVE(LN2)
. ; Process the text and save the data up to the last del piece
. Q
; This is to reset TEXT
S TEXT=$P(TEXT,SEP,DEL)
Q
FTOHL7(DATE) ; This subroutine will make a file manager date an HL7 date
N HLDATE,YYYY,MM,DD,HMS
S HLDATE=($E(DATE,1,3)+1700)_$E(DATE,4,7)_$P(DATE,".",2)
I $L(HLDATE)<14 S HLDATE=HLDATE_"00000000000000",HLDATE=$E(HLDATE,1,14)
Q HLDATE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMDHL7U2 5934 printed Apr 09, 2024@20:47:29 Page 2
MDHL7U2 ; HOIFO/WAA -Utilities for CP PROCESSING OBX text ; 7/26/00
+1 ;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004
+2 ; Supported IA #2263 for XPAR parameter calls.
+3 ; Supported IA #3006 for XMXAPIG calls.
+4 ; Supported IA #10106 for HL7 calls.
+5 ;
GET123(MDD702) ; return the IEN for an entry in 123 based on the 702
+1 ; This subroutine will return -1 if no entry is found
+2 NEW CONSULT
+3 SET CONSULT=-1
+4 ; Entry in 702 does exist
IF $GET(^MDD(702,MDD702,0))'=""
Begin DoDot:1
+5 ; Grab pointer to consults
SET CONSULT=$$GET1^DIQ(702,MDD702,.05,"I")
+6 ; Bad consult
IF CONSULT'>0
SET CONSULT=-1
QUIT
+7 QUIT
End DoDot:1
+8 QUIT CONSULT
GETREF(CONSULT) ; Return the physician and pointer to 200
+1 ; in the format pointer200^last^first
+2 NEW NREF,REF,PHY
+3 SET PHY=-1
+4 SET REF=$$GET1^DIQ(123,CONSULT,10,"I")
Begin DoDot:1
+5 if REF=""
QUIT
+6 SET NREF=$$GET1^DIQ(123,CONSULT,10,"E")
if NREF=""
QUIT
+7 SET NREF=$$HLNAME^HLFNC(NREF,"^~\&")
+8 SET PHY=REF_"^"_NREF
+9 QUIT
End DoDot:1
+10 QUIT PHY
+11 ;
MG(MG) ; This function is to validate that a mailgroup
+1 ; and that there is someone in it
+2 ;
+3 ; Input:
+4 ; MG the Mailgroup IEN in the file
+5 ;
+6 ; Output:
+7 ; 1 = Valid mail group with people in it
+8 ; 0 = Invalid group with No people in it
+9 ;
+10 NEW X,MGU
+11 SET X=0
IF '$GET(MG)
QUIT X
+12 SET MGU=$$GET1^DIQ(3.8,+MG_",",.01)
+13 IF MGU'=""
Begin DoDot:1
+14 IF $$GOTLOCAL^XMXAPIG(MGU)
SET X=1
+15 QUIT
End DoDot:1
+16 QUIT X
INST(DEV,X) ; Process Device and determine if the device Functioning
+1 ; DEV = Name of the device from the .01 field
+2 ; X = 1 is true that the device cleared to process
+3 ; 0 is false the device is not allowed to process
+4 ; X(0) = The device name^IEN^Print name if one^
+5 ; Processing routine^Routine Checksum^Patch Level
+6 ; X(I) = The reasons why it is OR is not allowed to process
+7 NEW LINE,I,J,Y
+8 SET I=0
+9 SET X=0
+10 IF DEV'?1N.N
SET DEV=$ORDER(^MDS(702.09,"B",DEV,0))
IF DEV<1
SET DEV=0
+11 SET LINE=$GET(^MDS(702.09,DEV,0))
+12 SET X(I)=$SELECT($PIECE(LINE,U)'="":$PIECE(LINE,U),1:"UNKNOWN")_U_DEV_U_$SELECT($PIECE(LINE,U)'="":$PIECE(LINE,U,6),1:"Device Unknown")
+13 IF LINE=""
SET I=I+1
SET X(I)="No Device Found."
QUIT
+14 IF $PIECE(LINE,U,6)=""
SET I=I+1
SET X(I)="No Print Name Defined."
+15 IF $PIECE(LINE,U,9)=""
SET I=I+1
SET X(I)="Active switch is not set for this device."
+16 IF $PIECE(LINE,U,9)'=1
SET I=I+1
SET X(I)="Device is set to Inactive."
+17 IF $PIECE(LINE,U,2)=""
SET I=I+1
SET X(I)="No Mail Group Defined in the instrument file."
+18 IF '$TEST
Begin DoDot:1
+19 if $$MG^MDHL7U2($PIECE(LINE,U,2))
QUIT
+20 NEW MGU
+21 IF $$FIND1^DIC(3.8,"","BX","MD DEVICE ERRORS")'=+$PIECE(LINE,U,2)
SET I=I+1
SET X(I)="No Mail Group Defined in VISTA."
QUIT
+22 SET MGU=$$GET1^DIQ(3.8,+$PIECE(LINE,U,2)_",",.01)
+23 IF '$$GOTLOCAL^XMXAPIG(MGU)
SET I=I+1
SET X(I)="No User are defined in the "_MGU_" Mail Group."
+24 QUIT
End DoDot:1
+25 SET LINE=$GET(^MDS(702.09,DEV,.1))
+26 IF $PIECE(LINE,U,1)=""
SET I=I+1
SET X(I)="No Processing routine indicated."
+27 IF '$TEST
Begin DoDot:1
+28 NEW ROU,ROUTINE
+29 SET ROUTINE=$PIECE(LINE,U,1)
+30 SET ROU=$$VALRTN^MDHL7U2($PIECE(LINE,U,1))
+31 IF 'ROU
SET I=I+1
SET X(I)="Processing routine does not exist."
+32 ; Plug in the needed information about the routine
IF '$TEST
Begin DoDot:2
+33 NEW LINE,SCND,HOLD
+34 SET LINE=X(0)
+35 ; processing routine
SET $PIECE(LINE,U,4)=ROU
+36 SET X(0)=LINE
+37 IF $EXTRACT(ROUTINE,1,2)="MD"
QUIT
+38 IF $EXTRACT(ROUTINE,1,2)="MC"
QUIT
+39 SET X(10)=" ***WARNING***"
+40 SET X(11)=" This will not stop the processing of instrument."
+41 SET X(12)=" Processing routine "_ROUTINE_" is not in CP Namespace."
+42 SET X(13)=" "
+43 SET X(14)=" ***WARNING***"
+44 QUIT
End DoDot:2
+45 QUIT
End DoDot:1
+46 IF $PIECE(LINE,U,2)=""
SET I=I+1
SET X(I)="No Package Code."
+47 IF $PIECE(LINE,U,2)'="M"
Begin DoDot:1
+48 NEW J,VLD
+49 SET VLD=0
+50 IF $PIECE(LINE,U,3)
Begin DoDot:2
+51 IF $PIECE(LINE,U,6)=""
SET I=I+1
SET X(I)="No HL7 Instrument ID."
+52 IF '$PIECE(LINE,U,8)
SET I=I+1
SET X(I)="No HL7 Link."
+53 QUIT
End DoDot:2
+54 SET LINE=$GET(^MDS(702.09,DEV,.3))
+55 FOR J=1:1:7
SET VLD=$PIECE(LINE,U,J)
IF VLD
QUIT
+56 IF 'VLD
SET I=I+1
SET X(I)="No Valid Attachment Types indicated."
+57 QUIT
End DoDot:1
+58 IF $$GET^XPAR("SYS","MD IMAGING XFER")=""
SET I=I+1
SET X(I)="No Imaging Share indicated in the Systems Parameters"
+59 IF I=0
SET X="1"
SET X(1)="Cleared to Process HL7 Messages"
+60 QUIT
VALRTN(RTN) ; Function to check Validity
+1 NEW X
+2 SET X=RTN
XECUTE ^%ZOSF("TEST")
SET X=$TEST
+3 QUIT X
TEXT ;;PROCESS TEXT;.302
+1 NEW CNT,LN,DEL
+2 SET SEP=$GET(SEP,"^")
+3 SET CNT=0
SET LN=0
SET DEL=0
+4 ; Create the entry in the multi.
SET MDDZ=$$UPDATE^MDHL7U(MDIEN)
+5 if 'MDDZ
QUIT
+6 SET ^MDD(703.1,MDIEN,.1,MDDZ,0)=$PIECE(MDATT(PROC),";",6)
+7 SET ^MDD(703.1,MDIEN,.1,MDDZ,.2,0)="^^"_LN_"^"_LN_"^"_DT_"^"
+8 FOR
SET CNT=$ORDER(^TMP($JOB,"MDHL7","TEXT",CNT))
if CNT<1
QUIT
Begin DoDot:1
+9 NEW LINE
+10 SET LINE=$GET(^TMP($JOB,"MDHL7","TEXT",CNT))
if LINE=""
QUIT
+11 IF $PIECE(LINE,"|",1)'="OBX"
QUIT
+12 IF $SELECT($PIECE(LINE,"|",3)="TX":0,$PIECE(LINE,"|",3)="FT":0,1:1)
QUIT
+13 IF $EXTRACT($PIECE(LINE,"|",6),1,2)="\\"
QUIT
+14 IF $EXTRACT($PIECE(LINE,"|",6),1,2)="//"
QUIT
+15 ; ^-- Quit if the line is not a text line or a freetext line.
+16 SET TEXT=$PIECE(LINE,"|",6)
if TEXT=""
QUIT
+17 IF $DATA(^TMP($JOB,"MDHL7","TEXT",CNT))=11
Begin DoDot:2
+18 ; Process the first line then go move on the the sub line
+19 DO PROCESS(.TEXT)
+20 NEW CNT2
+21 SET CNT2=0
+22 FOR
SET CNT2=$ORDER(^TMP($JOB,"MDHL7","TEXT",CNT,CNT2))
if CNT2<1
QUIT
Begin DoDot:3
+23 NEW MSG1
+24 SET MSG1=^TMP($JOB,"MDHL7","TEXT",CNT,CNT2)
+25 ; get the next message continution
+26 SET TEXT=TEXT_$PIECE(MSG1,SEP)
+27 DO SAVE(TEXT)
+28 SET TEXT=$PIECE(MSG1,SEP,2,($LENGTH(MSG1,SEP)))
+29 DO PROCESS(.TEXT)
+30 QUIT
End DoDot:3
+31 IF TEXT'=""
if TEXT["|"
SET TEXT=$PIECE(TEXT,"|")
DO SAVE(TEXT)
+32 QUIT
End DoDot:2
QUIT
+33 IF '$TEST
DO SAVE(TEXT)
+34 QUIT
End DoDot:1
+35 SET ^MDD(703.1,MDIEN,.1,MDDZ,.2,0)="^^"_LN_"^"_LN_"^"_DT_"^"
+36 QUIT
SAVE(TEXT) ; Save the data to the file 703.1
+1 SET LN=LN+1
+2 SET TEXT=$PIECE(TEXT,SEP)
+3 SET ^MDD(703.1,MDIEN,.1,MDDZ,.2,LN,0)=TEXT
+4 QUIT
PROCESS(TEXT) ; Long lines
+1 NEW I,LN2,DEL
+2 SET DEL=$LENGTH(TEXT,SEP)
+3 IF DEL'>1
Begin DoDot:1
+4 DO SAVE(TEXT)
+5 SET TEXT=""
End DoDot:1
QUIT
+6 FOR I=1:1:(DEL-1)
Begin DoDot:1
+7 SET LN2=$PIECE(TEXT,SEP,I)
+8 DO SAVE(LN2)
+9 ; Process the text and save the data up to the last del piece
+10 QUIT
End DoDot:1
+11 ; This is to reset TEXT
+12 SET TEXT=$PIECE(TEXT,SEP,DEL)
+13 QUIT
FTOHL7(DATE) ; This subroutine will make a file manager date an HL7 date
+1 NEW HLDATE,YYYY,MM,DD,HMS
+2 SET HLDATE=($EXTRACT(DATE,1,3)+1700)_$EXTRACT(DATE,4,7)_$PIECE(DATE,".",2)
+3 IF $LENGTH(HLDATE)<14
SET HLDATE=HLDATE_"00000000000000"
SET HLDATE=$EXTRACT(HLDATE,1,14)
+4 QUIT HLDATE
