HLUTIL2 ;ALB/MFK/MTC/JC - VARIOUS HL7 UTILITIES ;12/30/2010
;;1.6;HEALTH LEVEL SEVEN;**19,43,57,59,120,153**;;Build 11
;Per VHA Directive 2004-038, this routine should not be modified.
;
ITEM(IEN,ROUTINE) ; Return data from ITEM multiple in protocol file
; INPUT : IEN - Internal Entry Number for 101 (Protocol) file.
; ROUTINE - name of a routine to run (either PTR or TYPE)
;OUTPUT : HLARY - Array of IENs from ITEM multiple
; HLARY is of the form:
; HLARY(0)=Total number of items found
; HLARY(IEN)=Results from function
N ITEM,LINE,MSG,PTR
S IEN=$G(IEN)
Q:(IEN="")
S ROUTINE=$G(ROUTINE)
S ROUTINE=$S(ROUTINE="PTR":1,ROUTINE="TYPE":2,ROUTINE=1:1,ROUTINE=2:2,1:"")
Q:(ROUTINE="")
S ITEM="",MSG=0
; Loop through IENs within Subscriber multiple
F S ITEM=$O(^ORD(101,IEN,775,ITEM)) Q:(ITEM="") D
.S PTR=$P($G(^ORD(101,IEN,775,ITEM,0)),"^",1)
.; Call type to get info on that item
.S:(ROUTINE=1) LINE=$$PTR(PTR)
.S:(ROUTINE=2) LINE=$$TYPE(PTR)
.; Make sure LINE isn't error code
.I ((+LINE)>(-1)) S MSG=MSG+1 S HLARY(PTR)=LINE
S HLARY(0)=MSG
K ROUTINE
Q
PTR(IEN) ; Return pointer information if subscriber
; INPUT - IEN: IEN of protocol file
;OUTPUT - Line from ^ORD(101,IEN,770):
; CLIENT^LOGICAL_LINK (both pointers)
N RETURN,LINE,TYPE
S IEN=$G(IEN)
Q:(IEN="") "-1"
; Make sure this is a subscriber type
S TYPE=$P($G(^ORD(101,IEN,0)),"^",4)
Q:(TYPE'="S") "-2"
S LINE=$G(^ORD(101,IEN,770))
S RETURN=$P(LINE,"^",2)_"^"_$P(LINE,"^",7)
Q RETURN
TYPE(IEN) ; Return portions of protocol file
; INPUT - IEN: IEN of protocol file
;OUTPUT - Line containing the following information from the protocol
; file (#101)
;
; Client ^ Message Type Received ^ Event Type ^ Message Structure ^
; Processing ID ^ Logical Link Pointer ^ Accept Ack ^
; Application Ack ^ Version ^ Message Type Generated
;
N RETURN,CLP,MTPR,ETP,LINE,TYPE,CLIENT,EVENT,MTPEVP
N ACCACK,APPACK,VERID,VERIDP,ACKP,ACKTYP,MTPG,MTNEVN
;-- check if ien was passed in
S IEN=$G(IEN)
Q:(IEN="") "-1"
;
; Null any variables in case they don't exist
S (CLIENT,TYPE,EVENT,ACCACK,APPACK,VERID,MTPG,MTNEVN)=""
; Get line from protocol file
S LINE=$G(^ORD(101,IEN,770))
;
;-- get client (application that will receive the message
S CLP=$P(LINE,U,2)
S:(CLP) CLIENT=$P($G(^HL(771,CLP,0)),U,1)
;
;-- get message type received & generated
S MTPR=$P(LINE,U,3)
S MTPG=$P(LINE,U,11)
S:(MTPR) MTPR=$P($G(^HL(771.2,MTPR,0)),U,1)
S:(MTPG) MTPG=$P($G(^HL(771.2,MTPG,0)),U,1)
;
;-- get event type
S ETP=$P(LINE,U,4)
S:(ETP) EVENT=$P($G(^HL(779.001,ETP,0)),U,1)
;
;-- get message structure code
S MTPEVP=$P(LINE,U,5)
S:(MTPEVP) MTNEVN=$P($G(^HL(779.005,MTPEVP,0)),U,1)
;
;-- accept acknowledgement
S ACKP=$P(LINE,U,8)
S:(ACKP) ACCACK=$P($G(^HL(779.003,ACKP,0)),U,1)
;
;-- application acknowledgement
S ACKTYP=$P(LINE,U,9)
S:(ACKTYP) APPACK=$P($G(^HL(779.003,ACKTYP,0)),U,1)
;
;-- version of HL7
S VERIDP=$P(LINE,U,10)
S:(VERIDP) VERID=$P($G(^HL(771.5,VERIDP,0)),U,1)
;
;-- build return string
S RETURN=CLIENT_U_MTPR_U_EVENT
;-- 6 processing id, 7 logical link pointer
S RETURN=RETURN_U_MTNEVN_U_$P(LINE,U,6)_U_$P(LINE,U,7)
S RETURN=RETURN_U_ACCACK_U_APPACK_U_VERID_U_MTPG
Q RETURN
;
MSGADM(IEN) ; RETURN DATE/TIME ENTERED AND MSGID FROM FILE 773
N X
Q:'$G(^HLMA(+$G(IEN),0)) "-1" S X=^(0)
Q $P($G(^HL(772,+X,0)),"^")_"^"_$P(X,"^",2)
;
APPPRM(IEN) ; RETURN DATA FROM THE APPLICATION PARAMETER FILE
N LINE,COUNTRYP,COUNTRY
S IEN=$G(IEN)
Q:(IEN="")
S LINE=$G(^HL(771,IEN,0))
S COUNTRYP=$P(LINE,"^",7),COUNTRY=""
;
; patch HL*1.6*120 - for deleting "US" entry from #779.004
; I COUNTRYP]"" S COUNTRY=$P(^HL(779.004,COUNTRYP,0),"^",1)
I COUNTRYP]"" S COUNTRY=$P($G(^HL(779.004,COUNTRYP,0)),"^",1)
;
S APPPRM(IEN,0)=$P(LINE,"^",1)_"^"_$P(LINE,"^",3)_"^"_COUNTRY
S APPPRM(IEN,"EC")=$G(^HL(771,IEN,"EC"))
S:(APPPRM(IEN,"EC")="") APPPRM(IEN,"EC")="~|\&"
S APPPRM(IEN,"FS")=$G(^HL(771,IEN,"FS"))
S:(APPPRM(IEN,"FS")="") APPPRM(IEN,"FS")="^"
Q
CLRQUE ; Clear a queue by menu option
N DIC,DIR,DIRUT,HLDIR,HLERR,HLIEN,HLL,HLLTC,X,Y,TCP
S TCP=$O(^HLCS(869.1,"B","TCP",0))
S DIC("S")="I $P(^(0),U,3)'=TCP"
S DIC="^HLCS(870,",DIC(0)="AEQMZ"
D ^DIC Q:Y<0
K DIC S HLIEN=+Y,HLL=$P(Y(0),U,3)
L +^HLCS(870,HLIEN):1 E W !!,"Couldn't Lock Record, Try later.",! Q
S DIR(0)="S^B:BOTH QUEUES;I:IN QUEUE;O:OUT QUEUE",DIR("?")="Select the queue (in, out, or both) you would like cleared"
S DIR("A")="Enter which queue to clear",DIR("B")="B"
D ^DIR K DIR
S HLDIR=$S(Y="I":"IN",Y="O":"OUT",Y="B":"BOTH",1:1)
I HLDIR=1!$D(DIRUT) L -^HLCS(870,HLIEN) Q
;HLLTC= TCP service type
S:HLL HLLTC=$P($G(^HLCS(870,HLIEN,400)),U,3)
;TCP link
I $G(HLLTC)]"" D L -^HLCS(870,HLIEN) Q
. ;multiple server, set STATE and SHUTDOWN LLP?
. S:HLLTC="M" X=^HLCS(870,HLIEN,0),$P(X,U,5)="0 server",$P(X,U,15)=0,^(0)=X
. I HLDIR="BOTH" D Q
.. F X="IN","OUT" D CLRQUET(X)
. ;do one que
. D CLRQUET(HLDIR)
;
I HLDIR="BOTH" D
. S HLERR=$$CLEARQUE^HLCSQUE(HLIEN,"OUT")
. I HLERR W !,"Error in clearing out queue:",$P(HLERR,"^",2)
. S HLERR=$$CLEARQUE^HLCSQUE(HLIEN,"IN")
. I HLERR W !,"Error in clearing in queue:",$P(HLERR,"^",2)
I HLDIR'="BOTH" S HLERR=$$CLEARQUE^HLCSQUE(HLIEN,HLDIR)
L -^HLCS(870,HLIEN)
Q
CLRQUET(Y) ;subroutine for TCP links, Y=IN or OUT
Q:Y'="IN"&(Y'="OUT")
N C,N,X
S N=$E(Y),X=0
;get count of what is pending
F C=0:1 S X=$O(^HLMA("AC",N,HLIEN,X)) Q:'X
;reset counters for messages
S ^HLCS(870,HLIEN,Y_" QUEUE BACK POINTER")=C,^(Y_" QUEUE FRONT POINTER")=0
Q
;
SHGLLP ; Show Gross LLP Error
N DIC,IEN,ERR
S DIC="^HLCS(870,"
S DIC(0)="AEQM"
D ^DIC K DIC
S IEN=$P(Y,"^",1)
S ERR=$P($G(^HLCS(870,IEN,0)),"^",19)
W:(ERR'="") !,"Error: "_$P($G(^HL(771.7,ERR,0)),"^",1),!
W:(ERR="") !,"No Gross LLP error found",!
Q
CLGLLP ; Clear Gross LLP error
N DIC,IEN,ERR,DA,DR
S DIC="^HLCS(870,"
S DIC(0)="AEQM"
D ^DIC K DIC
S IEN=$P(Y,"^",1)
Q:(IEN<0)
S DIE="^HLCS(870,"
S DA=IEN
S DR="18///@"
D ^DIE K DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLUTIL2 6182 printed Dec 13, 2024@02:00:28 Page 2
HLUTIL2 ;ALB/MFK/MTC/JC - VARIOUS HL7 UTILITIES ;12/30/2010
+1 ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,59,120,153**;;Build 11
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
ITEM(IEN,ROUTINE) ; Return data from ITEM multiple in protocol file
+1 ; INPUT : IEN - Internal Entry Number for 101 (Protocol) file.
+2 ; ROUTINE - name of a routine to run (either PTR or TYPE)
+3 ;OUTPUT : HLARY - Array of IENs from ITEM multiple
+4 ; HLARY is of the form:
+5 ; HLARY(0)=Total number of items found
+6 ; HLARY(IEN)=Results from function
+7 NEW ITEM,LINE,MSG,PTR
+8 SET IEN=$GET(IEN)
+9 if (IEN="")
QUIT
+10 SET ROUTINE=$GET(ROUTINE)
+11 SET ROUTINE=$SELECT(ROUTINE="PTR":1,ROUTINE="TYPE":2,ROUTINE=1:1,ROUTINE=2:2,1:"")
+12 if (ROUTINE="")
QUIT
+13 SET ITEM=""
SET MSG=0
+14 ; Loop through IENs within Subscriber multiple
+15 FOR
SET ITEM=$ORDER(^ORD(101,IEN,775,ITEM))
if (ITEM="")
QUIT
Begin DoDot:1
+16 SET PTR=$PIECE($GET(^ORD(101,IEN,775,ITEM,0)),"^",1)
+17 ; Call type to get info on that item
+18 if (ROUTINE=1)
SET LINE=$$PTR(PTR)
+19 if (ROUTINE=2)
SET LINE=$$TYPE(PTR)
+20 ; Make sure LINE isn't error code
+21 IF ((+LINE)>(-1))
SET MSG=MSG+1
SET HLARY(PTR)=LINE
End DoDot:1
+22 SET HLARY(0)=MSG
+23 KILL ROUTINE
+24 QUIT
PTR(IEN) ; Return pointer information if subscriber
+1 ; INPUT - IEN: IEN of protocol file
+2 ;OUTPUT - Line from ^ORD(101,IEN,770):
+3 ; CLIENT^LOGICAL_LINK (both pointers)
+4 NEW RETURN,LINE,TYPE
+5 SET IEN=$GET(IEN)
+6 if (IEN="")
QUIT "-1"
+7 ; Make sure this is a subscriber type
+8 SET TYPE=$PIECE($GET(^ORD(101,IEN,0)),"^",4)
+9 if (TYPE'="S")
QUIT "-2"
+10 SET LINE=$GET(^ORD(101,IEN,770))
+11 SET RETURN=$PIECE(LINE,"^",2)_"^"_$PIECE(LINE,"^",7)
+12 QUIT RETURN
TYPE(IEN) ; Return portions of protocol file
+1 ; INPUT - IEN: IEN of protocol file
+2 ;OUTPUT - Line containing the following information from the protocol
+3 ; file (#101)
+4 ;
+5 ; Client ^ Message Type Received ^ Event Type ^ Message Structure ^
+6 ; Processing ID ^ Logical Link Pointer ^ Accept Ack ^
+7 ; Application Ack ^ Version ^ Message Type Generated
+8 ;
+9 NEW RETURN,CLP,MTPR,ETP,LINE,TYPE,CLIENT,EVENT,MTPEVP
+10 NEW ACCACK,APPACK,VERID,VERIDP,ACKP,ACKTYP,MTPG,MTNEVN
+11 ;-- check if ien was passed in
+12 SET IEN=$GET(IEN)
+13 if (IEN="")
QUIT "-1"
+14 ;
+15 ; Null any variables in case they don't exist
+16 SET (CLIENT,TYPE,EVENT,ACCACK,APPACK,VERID,MTPG,MTNEVN)=""
+17 ; Get line from protocol file
+18 SET LINE=$GET(^ORD(101,IEN,770))
+19 ;
+20 ;-- get client (application that will receive the message
+21 SET CLP=$PIECE(LINE,U,2)
+22 if (CLP)
SET CLIENT=$PIECE($GET(^HL(771,CLP,0)),U,1)
+23 ;
+24 ;-- get message type received & generated
+25 SET MTPR=$PIECE(LINE,U,3)
+26 SET MTPG=$PIECE(LINE,U,11)
+27 if (MTPR)
SET MTPR=$PIECE($GET(^HL(771.2,MTPR,0)),U,1)
+28 if (MTPG)
SET MTPG=$PIECE($GET(^HL(771.2,MTPG,0)),U,1)
+29 ;
+30 ;-- get event type
+31 SET ETP=$PIECE(LINE,U,4)
+32 if (ETP)
SET EVENT=$PIECE($GET(^HL(779.001,ETP,0)),U,1)
+33 ;
+34 ;-- get message structure code
+35 SET MTPEVP=$PIECE(LINE,U,5)
+36 if (MTPEVP)
SET MTNEVN=$PIECE($GET(^HL(779.005,MTPEVP,0)),U,1)
+37 ;
+38 ;-- accept acknowledgement
+39 SET ACKP=$PIECE(LINE,U,8)
+40 if (ACKP)
SET ACCACK=$PIECE($GET(^HL(779.003,ACKP,0)),U,1)
+41 ;
+42 ;-- application acknowledgement
+43 SET ACKTYP=$PIECE(LINE,U,9)
+44 if (ACKTYP)
SET APPACK=$PIECE($GET(^HL(779.003,ACKTYP,0)),U,1)
+45 ;
+46 ;-- version of HL7
+47 SET VERIDP=$PIECE(LINE,U,10)
+48 if (VERIDP)
SET VERID=$PIECE($GET(^HL(771.5,VERIDP,0)),U,1)
+49 ;
+50 ;-- build return string
+51 SET RETURN=CLIENT_U_MTPR_U_EVENT
+52 ;-- 6 processing id, 7 logical link pointer
+53 SET RETURN=RETURN_U_MTNEVN_U_$PIECE(LINE,U,6)_U_$PIECE(LINE,U,7)
+54 SET RETURN=RETURN_U_ACCACK_U_APPACK_U_VERID_U_MTPG
+55 QUIT RETURN
+56 ;
MSGADM(IEN) ; RETURN DATE/TIME ENTERED AND MSGID FROM FILE 773
+1 NEW X
+2 if '$GET(^HLMA(+$GET(IEN),0))
QUIT "-1"
SET X=^(0)
+3 QUIT $PIECE($GET(^HL(772,+X,0)),"^")_"^"_$PIECE(X,"^",2)
+4 ;
APPPRM(IEN) ; RETURN DATA FROM THE APPLICATION PARAMETER FILE
+1 NEW LINE,COUNTRYP,COUNTRY
+2 SET IEN=$GET(IEN)
+3 if (IEN="")
QUIT
+4 SET LINE=$GET(^HL(771,IEN,0))
+5 SET COUNTRYP=$PIECE(LINE,"^",7)
SET COUNTRY=""
+6 ;
+7 ; patch HL*1.6*120 - for deleting "US" entry from #779.004
+8 ; I COUNTRYP]"" S COUNTRY=$P(^HL(779.004,COUNTRYP,0),"^",1)
+9 IF COUNTRYP]""
SET COUNTRY=$PIECE($GET(^HL(779.004,COUNTRYP,0)),"^",1)
+10 ;
+11 SET APPPRM(IEN,0)=$PIECE(LINE,"^",1)_"^"_$PIECE(LINE,"^",3)_"^"_COUNTRY
+12 SET APPPRM(IEN,"EC")=$GET(^HL(771,IEN,"EC"))
+13 if (APPPRM(IEN,"EC")="")
SET APPPRM(IEN,"EC")="~|\&"
+14 SET APPPRM(IEN,"FS")=$GET(^HL(771,IEN,"FS"))
+15 if (APPPRM(IEN,"FS")="")
SET APPPRM(IEN,"FS")="^"
+16 QUIT
CLRQUE ; Clear a queue by menu option
+1 NEW DIC,DIR,DIRUT,HLDIR,HLERR,HLIEN,HLL,HLLTC,X,Y,TCP
+2 SET TCP=$ORDER(^HLCS(869.1,"B","TCP",0))
+3 SET DIC("S")="I $P(^(0),U,3)'=TCP"
+4 SET DIC="^HLCS(870,"
SET DIC(0)="AEQMZ"
+5 DO ^DIC
if Y<0
QUIT
+6 KILL DIC
SET HLIEN=+Y
SET HLL=$PIECE(Y(0),U,3)
+7 LOCK +^HLCS(870,HLIEN):1
IF '$TEST
WRITE !!,"Couldn't Lock Record, Try later.",!
QUIT
+8 SET DIR(0)="S^B:BOTH QUEUES;I:IN QUEUE;O:OUT QUEUE"
SET DIR("?")="Select the queue (in, out, or both) you would like cleared"
+9 SET DIR("A")="Enter which queue to clear"
SET DIR("B")="B"
+10 DO ^DIR
KILL DIR
+11 SET HLDIR=$SELECT(Y="I":"IN",Y="O":"OUT",Y="B":"BOTH",1:1)
+12 IF HLDIR=1!$DATA(DIRUT)
LOCK -^HLCS(870,HLIEN)
QUIT
+13 ;HLLTC= TCP service type
+14 if HLL
SET HLLTC=$PIECE($GET(^HLCS(870,HLIEN,400)),U,3)
+15 ;TCP link
+16 IF $GET(HLLTC)]""
Begin DoDot:1
+17 ;multiple server, set STATE and SHUTDOWN LLP?
+18 if HLLTC="M"
SET X=^HLCS(870,HLIEN,0)
SET $PIECE(X,U,5)="0 server"
SET $PIECE(X,U,15)=0
SET ^(0)=X
+19 IF HLDIR="BOTH"
Begin DoDot:2
+20 FOR X="IN","OUT"
DO CLRQUET(X)
End DoDot:2
QUIT
+21 ;do one que
+22 DO CLRQUET(HLDIR)
End DoDot:1
LOCK -^HLCS(870,HLIEN)
QUIT
+23 ;
+24 IF HLDIR="BOTH"
Begin DoDot:1
+25 SET HLERR=$$CLEARQUE^HLCSQUE(HLIEN,"OUT")
+26 IF HLERR
WRITE !,"Error in clearing out queue:",$PIECE(HLERR,"^",2)
+27 SET HLERR=$$CLEARQUE^HLCSQUE(HLIEN,"IN")
+28 IF HLERR
WRITE !,"Error in clearing in queue:",$PIECE(HLERR,"^",2)
End DoDot:1
+29 IF HLDIR'="BOTH"
SET HLERR=$$CLEARQUE^HLCSQUE(HLIEN,HLDIR)
+30 LOCK -^HLCS(870,HLIEN)
+31 QUIT
CLRQUET(Y) ;subroutine for TCP links, Y=IN or OUT
+1 if Y'="IN"&(Y'="OUT")
QUIT
+2 NEW C,N,X
+3 SET N=$EXTRACT(Y)
SET X=0
+4 ;get count of what is pending
+5 FOR C=0:1
SET X=$ORDER(^HLMA("AC",N,HLIEN,X))
if 'X
QUIT
+6 ;reset counters for messages
+7 SET ^HLCS(870,HLIEN,Y_" QUEUE BACK POINTER")=C
SET ^(Y_" QUEUE FRONT POINTER")=0
+8 QUIT
+9 ;
SHGLLP ; Show Gross LLP Error
+1 NEW DIC,IEN,ERR
+2 SET DIC="^HLCS(870,"
+3 SET DIC(0)="AEQM"
+4 DO ^DIC
KILL DIC
+5 SET IEN=$PIECE(Y,"^",1)
+6 SET ERR=$PIECE($GET(^HLCS(870,IEN,0)),"^",19)
+7 if (ERR'="")
WRITE !,"Error: "_$PIECE($GET(^HL(771.7,ERR,0)),"^",1),!
+8 if (ERR="")
WRITE !,"No Gross LLP error found",!
+9 QUIT
CLGLLP ; Clear Gross LLP error
+1 NEW DIC,IEN,ERR,DA,DR
+2 SET DIC="^HLCS(870,"
+3 SET DIC(0)="AEQM"
+4 DO ^DIC
KILL DIC
+5 SET IEN=$PIECE(Y,"^",1)
+6 if (IEN<0)
QUIT
+7 SET DIE="^HLCS(870,"
+8 SET DA=IEN
+9 SET DR="18///@"
+10 DO ^DIE
KILL DIE
+11 QUIT
