Routine: MDHL7U2

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"

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_"^"

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

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)

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  Feb 18, 2025@23:09:20                                                                                                                                                                                                     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

MDHL7U2.m