- 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 Jan 18, 2025@03:01:43 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