Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: HLUTIL2

HLUTIL2.m

Go to the documentation of this file.
  1. 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
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ITEM(IEN,ROUTINE) ; Return data from ITEM multiple in protocol file
  1. ; INPUT : IEN - Internal Entry Number for 101 (Protocol) file.
  1. ; ROUTINE - name of a routine to run (either PTR or TYPE)
  1. ;OUTPUT : HLARY - Array of IENs from ITEM multiple
  1. ; HLARY is of the form:
  1. ; HLARY(0)=Total number of items found
  1. ; HLARY(IEN)=Results from function
  1. N ITEM,LINE,MSG,PTR
  1. S IEN=$G(IEN)
  1. Q:(IEN="")
  1. S ROUTINE=$G(ROUTINE)
  1. S ROUTINE=$S(ROUTINE="PTR":1,ROUTINE="TYPE":2,ROUTINE=1:1,ROUTINE=2:2,1:"")
  1. Q:(ROUTINE="")
  1. S ITEM="",MSG=0
  1. ; Loop through IENs within Subscriber multiple
  1. F S ITEM=$O(^ORD(101,IEN,775,ITEM)) Q:(ITEM="") D
  1. .S PTR=$P($G(^ORD(101,IEN,775,ITEM,0)),"^",1)
  1. .; Call type to get info on that item
  1. .S:(ROUTINE=1) LINE=$$PTR(PTR)
  1. .S:(ROUTINE=2) LINE=$$TYPE(PTR)
  1. .; Make sure LINE isn't error code
  1. .I ((+LINE)>(-1)) S MSG=MSG+1 S HLARY(PTR)=LINE
  1. S HLARY(0)=MSG
  1. K ROUTINE
  1. Q
  1. PTR(IEN) ; Return pointer information if subscriber
  1. ; INPUT - IEN: IEN of protocol file
  1. ;OUTPUT - Line from ^ORD(101,IEN,770):
  1. ; CLIENT^LOGICAL_LINK (both pointers)
  1. N RETURN,LINE,TYPE
  1. S IEN=$G(IEN)
  1. Q:(IEN="") "-1"
  1. ; Make sure this is a subscriber type
  1. S TYPE=$P($G(^ORD(101,IEN,0)),"^",4)
  1. Q:(TYPE'="S") "-2"
  1. S LINE=$G(^ORD(101,IEN,770))
  1. S RETURN=$P(LINE,"^",2)_"^"_$P(LINE,"^",7)
  1. Q RETURN
  1. TYPE(IEN) ; Return portions of protocol file
  1. ; INPUT - IEN: IEN of protocol file
  1. ;OUTPUT - Line containing the following information from the protocol
  1. ; file (#101)
  1. ;
  1. ; Client ^ Message Type Received ^ Event Type ^ Message Structure ^
  1. ; Processing ID ^ Logical Link Pointer ^ Accept Ack ^
  1. ; Application Ack ^ Version ^ Message Type Generated
  1. ;
  1. N RETURN,CLP,MTPR,ETP,LINE,TYPE,CLIENT,EVENT,MTPEVP
  1. N ACCACK,APPACK,VERID,VERIDP,ACKP,ACKTYP,MTPG,MTNEVN
  1. ;-- check if ien was passed in
  1. S IEN=$G(IEN)
  1. Q:(IEN="") "-1"
  1. ;
  1. ; Null any variables in case they don't exist
  1. S (CLIENT,TYPE,EVENT,ACCACK,APPACK,VERID,MTPG,MTNEVN)=""
  1. ; Get line from protocol file
  1. S LINE=$G(^ORD(101,IEN,770))
  1. ;
  1. ;-- get client (application that will receive the message
  1. S CLP=$P(LINE,U,2)
  1. S:(CLP) CLIENT=$P($G(^HL(771,CLP,0)),U,1)
  1. ;
  1. ;-- get message type received & generated
  1. S MTPR=$P(LINE,U,3)
  1. S MTPG=$P(LINE,U,11)
  1. S:(MTPR) MTPR=$P($G(^HL(771.2,MTPR,0)),U,1)
  1. S:(MTPG) MTPG=$P($G(^HL(771.2,MTPG,0)),U,1)
  1. ;
  1. ;-- get event type
  1. S ETP=$P(LINE,U,4)
  1. S:(ETP) EVENT=$P($G(^HL(779.001,ETP,0)),U,1)
  1. ;
  1. ;-- get message structure code
  1. S MTPEVP=$P(LINE,U,5)
  1. S:(MTPEVP) MTNEVN=$P($G(^HL(779.005,MTPEVP,0)),U,1)
  1. ;
  1. ;-- accept acknowledgement
  1. S ACKP=$P(LINE,U,8)
  1. S:(ACKP) ACCACK=$P($G(^HL(779.003,ACKP,0)),U,1)
  1. ;
  1. ;-- application acknowledgement
  1. S ACKTYP=$P(LINE,U,9)
  1. S:(ACKTYP) APPACK=$P($G(^HL(779.003,ACKTYP,0)),U,1)
  1. ;
  1. ;-- version of HL7
  1. S VERIDP=$P(LINE,U,10)
  1. S:(VERIDP) VERID=$P($G(^HL(771.5,VERIDP,0)),U,1)
  1. ;
  1. ;-- build return string
  1. S RETURN=CLIENT_U_MTPR_U_EVENT
  1. ;-- 6 processing id, 7 logical link pointer
  1. S RETURN=RETURN_U_MTNEVN_U_$P(LINE,U,6)_U_$P(LINE,U,7)
  1. S RETURN=RETURN_U_ACCACK_U_APPACK_U_VERID_U_MTPG
  1. Q RETURN
  1. ;
  1. MSGADM(IEN) ; RETURN DATE/TIME ENTERED AND MSGID FROM FILE 773
  1. N X
  1. Q:'$G(^HLMA(+$G(IEN),0)) "-1" S X=^(0)
  1. Q $P($G(^HL(772,+X,0)),"^")_"^"_$P(X,"^",2)
  1. ;
  1. APPPRM(IEN) ; RETURN DATA FROM THE APPLICATION PARAMETER FILE
  1. N LINE,COUNTRYP,COUNTRY
  1. S IEN=$G(IEN)
  1. Q:(IEN="")
  1. S LINE=$G(^HL(771,IEN,0))
  1. S COUNTRYP=$P(LINE,"^",7),COUNTRY=""
  1. ;
  1. ; patch HL*1.6*120 - for deleting "US" entry from #779.004
  1. ; I COUNTRYP]"" S COUNTRY=$P(^HL(779.004,COUNTRYP,0),"^",1)
  1. I COUNTRYP]"" S COUNTRY=$P($G(^HL(779.004,COUNTRYP,0)),"^",1)
  1. ;
  1. S APPPRM(IEN,0)=$P(LINE,"^",1)_"^"_$P(LINE,"^",3)_"^"_COUNTRY
  1. S APPPRM(IEN,"EC")=$G(^HL(771,IEN,"EC"))
  1. S:(APPPRM(IEN,"EC")="") APPPRM(IEN,"EC")="~|\&"
  1. S APPPRM(IEN,"FS")=$G(^HL(771,IEN,"FS"))
  1. S:(APPPRM(IEN,"FS")="") APPPRM(IEN,"FS")="^"
  1. Q
  1. CLRQUE ; Clear a queue by menu option
  1. N DIC,DIR,DIRUT,HLDIR,HLERR,HLIEN,HLL,HLLTC,X,Y,TCP
  1. S TCP=$O(^HLCS(869.1,"B","TCP",0))
  1. S DIC("S")="I $P(^(0),U,3)'=TCP"
  1. S DIC="^HLCS(870,",DIC(0)="AEQMZ"
  1. D ^DIC Q:Y<0
  1. K DIC S HLIEN=+Y,HLL=$P(Y(0),U,3)
  1. L +^HLCS(870,HLIEN):1 E W !!,"Couldn't Lock Record, Try later.",! Q
  1. 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"
  1. S DIR("A")="Enter which queue to clear",DIR("B")="B"
  1. D ^DIR K DIR
  1. S HLDIR=$S(Y="I":"IN",Y="O":"OUT",Y="B":"BOTH",1:1)
  1. I HLDIR=1!$D(DIRUT) L -^HLCS(870,HLIEN) Q
  1. ;HLLTC= TCP service type
  1. S:HLL HLLTC=$P($G(^HLCS(870,HLIEN,400)),U,3)
  1. ;TCP link
  1. I $G(HLLTC)]"" D L -^HLCS(870,HLIEN) Q
  1. . ;multiple server, set STATE and SHUTDOWN LLP?
  1. . S:HLLTC="M" X=^HLCS(870,HLIEN,0),$P(X,U,5)="0 server",$P(X,U,15)=0,^(0)=X
  1. . I HLDIR="BOTH" D Q
  1. .. F X="IN","OUT" D CLRQUET(X)
  1. . ;do one que
  1. . D CLRQUET(HLDIR)
  1. ;
  1. I HLDIR="BOTH" D
  1. . S HLERR=$$CLEARQUE^HLCSQUE(HLIEN,"OUT")
  1. . I HLERR W !,"Error in clearing out queue:",$P(HLERR,"^",2)
  1. . S HLERR=$$CLEARQUE^HLCSQUE(HLIEN,"IN")
  1. . I HLERR W !,"Error in clearing in queue:",$P(HLERR,"^",2)
  1. I HLDIR'="BOTH" S HLERR=$$CLEARQUE^HLCSQUE(HLIEN,HLDIR)
  1. L -^HLCS(870,HLIEN)
  1. Q
  1. CLRQUET(Y) ;subroutine for TCP links, Y=IN or OUT
  1. Q:Y'="IN"&(Y'="OUT")
  1. N C,N,X
  1. S N=$E(Y),X=0
  1. ;get count of what is pending
  1. F C=0:1 S X=$O(^HLMA("AC",N,HLIEN,X)) Q:'X
  1. ;reset counters for messages
  1. S ^HLCS(870,HLIEN,Y_" QUEUE BACK POINTER")=C,^(Y_" QUEUE FRONT POINTER")=0
  1. Q
  1. ;
  1. SHGLLP ; Show Gross LLP Error
  1. N DIC,IEN,ERR
  1. S DIC="^HLCS(870,"
  1. S DIC(0)="AEQM"
  1. D ^DIC K DIC
  1. S IEN=$P(Y,"^",1)
  1. S ERR=$P($G(^HLCS(870,IEN,0)),"^",19)
  1. W:(ERR'="") !,"Error: "_$P($G(^HL(771.7,ERR,0)),"^",1),!
  1. W:(ERR="") !,"No Gross LLP error found",!
  1. Q
  1. CLGLLP ; Clear Gross LLP error
  1. N DIC,IEN,ERR,DA,DR
  1. S DIC="^HLCS(870,"
  1. S DIC(0)="AEQM"
  1. D ^DIC K DIC
  1. S IEN=$P(Y,"^",1)
  1. Q:(IEN<0)
  1. S DIE="^HLCS(870,"
  1. S DA=IEN
  1. S DR="18///@"
  1. D ^DIE K DIE
  1. Q