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

INHUT7.m

Go to the documentation of this file. 
  1. INHUT7 ; KAC ; 8 Jan 98 17:16; HL7 Utilities 
  1.  ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
  1.  ;COPYRIGHT 1991-2000 SAIC
  1.  Q
  1.  ;
  1. GETDEST(INACKTT,INA,INACKDST,INACKUIF) ; $$function - Used to support routing
  1.  ; of Application Acknowledgement messages to the originating system
  1.  ; when multiple instantiations of a remote system type exist.  Only
  1.  ; one of the input parameters (INA,INACKDST,INACKUIF) must be
  1.  ; specified by the caller to route an Application Ack.  If a valid
  1.  ; destination cannot be identified, a fatal script error is logged
  1.  ; and the O/P Ctlr will log an error in ^INTHER.
  1.  ;
  1.  ; Called by:  SCRIPT GENERATOR MESSAGE file, Outgoing Initial MUMPS
  1.  ;             Code field, S INDEST=$$GETDEST^INHUT(INTT,.INA,INDEST)
  1.  ;
  1.  ; Input:
  1.  ;   INACKTT  - (req) INTERFACE TRANSACTION TYPE IEN for Application
  1.  ;                    Ack.  Used for error handling.
  1.  ;   INA      - (req) array containing information for routing
  1.  ;                    Application Ack to originator's dest as
  1.  ;                    specified by GIS Receiver
  1.  ;   INACKDST - (opt) INTERFACE DESTINATION IEN for outbound
  1.  ;                    Application Ack as specified by user
  1.  ;   INACKUIF - (opt) UNIVERSAL INTERFACE IEN for outbound Application
  1.  ;                    Ack.  Contains destination specified for this
  1.  ;                    Ack at time of Ack creation.  Future implementation.
  1.  ;
  1.  ; Variables:
  1.  ;   X        - scratch
  1.  ;   INERRMSG - error message to be returned in INHERR by Ack script
  1.  ;
  1.  ; Output:
  1.  ;   - INTERFACE DESTINATION IEN for outbound Application Ack
  1.  ;   - "" if fails to find valid dest
  1.  ;
  1.  N INERRMSG,X
  1.  ;
  1.  ; GIS-Receiver-specified dest
  1.  I $G(INA("INDEST")),$D(^INRHD(INA("INDEST"),0)) Q INA("INDEST")
  1.  ;
  1.  ; User-specified dest
  1.  I $G(INACKDST),$D(^INRHD(INACKDST,0)) Q INACKDST
  1.  ;
  1.  ; Ack msg exists - use dest specified at time of msg creation
  1.  I $G(INACKUIF) S X=$P($G(^INTHU(INACKUIF,0)),U,2) I X,$D(^INRHD(X,0)) Q X
  1.  ;
  1.  ; Error - no valid destinations identified
  1.  S INERRMSG="Application Ack creation failed - no valid destinations identified for Ack transaction type "_$S($G(INACKTT):$P($G(^INRHT(INACKTT,0)),U),1:"")
  1.  D ERROR^INHS(INERRMSG,2) ; fatal Ack script error - set INHERR
  1.  Q ""
  1.  ;
  1. SUBESC(INREC,INDEL,INB) ;Substitute escape delimeters to and from HL7
  1.  ;                        spec
  1.  ;Input:
  1.  ; INREC - Portion of HL7 MSG to check
  1.  ; INDEL(opt) = FSRET values - each position is critical
  1.  ;              ie S INDEL="^\|~&"
  1.  ;                       or
  1.  ;              array of delimiters
  1.  ;              S INDEL("F")="^"
  1.  ;              S INDEL("S")="\"
  1.  ;              S INDEL("R")="|"
  1.  ;              S INDEL("E")="~"
  1.  ;              S INDEL("T")="&"
  1.  ; INB - I inbound, O outbound
  1.  ;Returns - Record with replace values
  1.  ;Outbound
  1.  Q:$G(INB)="O" $$CNVDLM(.INREC,.INDEL)
  1.  ;Inbound
  1.  Q:$G(INB)="I" $$DLMCNV(.INREC,.INDEL)
  1.  Q INREC
  1. CNVDLM(INREC,INDEL) ;;Convert delimeters to HL7 specifications if in record
  1.  ; Input: INREC - Portion of HL7 MSG to check
  1.  ;        INDEL(opt) = FSRET values - each position is critical
  1.  ;                  ie S INDEL="^\|~&"
  1.  ;                          or
  1.  ;                  array of delimiters
  1.  ;                    S INDEL("F")="^"
  1.  ;                    S INDEL("S")="\"
  1.  ;                    S INDEL("R")="|"
  1.  ;                    S INDEL("E")="~"
  1.  ;                    S INDEL("T")="&"
  1.  ; Returns - Record with replace values
  1.  ;
  1.  N INF,I,J,K,E,R,S,F,T,INREC1,IND
  1.  S (INREC1,E,R,S,F,T)="",IND="FSRET"
  1.  I $L($G(INDEL)) F I=1:1:5 S @$E(IND,I)=$E(INDEL,I)
  1.  E  I $D(INDEL)>1 S I="" F  S I=$O(INDEL(I)) Q:I=""  S @I=INDEL(I)
  1.  S:E="" E=$$ESC^INHUT() S:R="" R=$$REP^INHUT() S:S="" S=$$COMP^INHUT()
  1.  S:F="" F=$$FIELD^INHUT() S:T="" T=$$SUBCOMP^INHUT()
  1.  ;
  1.  ;Set array of HL7 delimters to replacement value
  1.  S J(R)=E_"R"_E,J(S)=E_"S"_E,J(E)=E_"E"_E,J(F)=E_"F"_E,J(T)=E_"T"_E
  1.  ;
  1.  ;loop through record looking for HL7 delimters
  1.  F K=1:1:$L(INREC) D
  1.  .;if special character doesn't exist keep else replace
  1.  .I '$D(J($E(INREC,K))) S INREC1=INREC1_$E(INREC,K)
  1.  .E  S INREC1=INREC1_J($E(INREC,K))
  1.  Q INREC1
  1. DLMCNV(INREC,INDEL) ;;HL7 specifications to correct delimitor if in record
  1.  ; Input: INREC - Portion of HL7 MSG to check
  1.  ;        INDEL(opt) = FSRET values - each position is critical
  1.  ;                  ie S INDEL="^\|~&"
  1.  ;                          or
  1.  ;                  array of delimiters
  1.  ;                    S INDEL("F")="^"
  1.  ;                    S INDEL("S")="\"
  1.  ;                    S INDEL("R")="|"
  1.  ;                    S INDEL("E")="~"
  1.  ;                    S INDEL("T")="&"
  1.  ; Returns - Record with replace values
  1.  ;
  1.  N INF,I,J,K,E,R,S,F,T,INREC1,IND
  1.  S (INREC1,E,R,S,F,T)="",IND="FSRET"
  1.  I $L($G(INDEL)) F I=1:1:5 S @$E(IND,I)=$E(INDEL,I)
  1.  E  I $D(INDEL)>1 S I="" F  S I=$O(INDEL(I)) Q:I=""  S @I=INDEL(I)
  1.  S:E="" E=$$ESC^INHUT() S:R="" R=$$REP^INHUT() S:S="" S=$$COMP^INHUT()
  1.  S:F="" F=$$FIELD^INHUT() S:T="" T=$$SUBCOMP^INHUT()
  1.  ;
  1.  ;Set array of HL7 delimters to replacement value
  1.  S J("R")=R,J("S")=S,J("E")=E,J("F")=F,J("T")=T
  1.  ;
  1.  ;loop through record looking for HL7 delimters
  1.  F  S K=$F(INREC,E) Q:'K!($E(INREC,K+1)="")  I $E(INREC,K+1)=E D
  1.  .S INREC1=INREC1_$E(INREC,1,K-2)
  1.  .I $D(J($E(INREC,K))) S INREC1=INREC1_J($E(INREC,K))
  1.  .E  S INREC1=INREC1_$E(INREC,K-1,K+1)
  1.  .S INREC=$E(INREC,K+2,$L(INREC))
  1.  S INREC1=INREC1_INREC
  1.  Q INREC1
  1. APPACK(INUIF,INAKMES,INASTAT,INERMSG) ;User API to ACKLOG^INHU
  1.  ;
  1.  ; Inputs:
  1.  ;   INUIF   = UIF ien of ack message in Universal Interface file
  1.  ;   INAKMES = Acked message ID - Typically: @INV@("MSA2")
  1.  ;   INASTAT = Ack message status - Typically: @INV@("MSA1"), converted
  1.  ;             to 0=NAK or 1=ACK.  ex: S INASTAT=("AA"=INASTAT)
  1.  ;   INERMSG = Message to store if NAK. Typically: @INV@("MSA6")
  1.  ;
  1.  ; Usage:
  1.  ;     D APPACK^INHUT(UIF,@INV@("MSA2"),@INV@("MSA1"),@INV@("MSA6"))
  1.  ;
  1.  S INAKMES=$G(INAKMES),INASTAT=$G(INASTAT),INERMSG=$G(INERMSG)
  1.  N INFERR,INFMSG
  1.  S (INFERR,INFMSG)=""
  1.  ;
  1.  I INAKMES="" S INFMSG="No message identified to acknowledge",INFERR=2
  1.  I 'INFERR D  ;save the worst error
  1.  .I '$D(^INTHU("C",INAKMES)) S INFMSG="Acknowledge for unknown message ID - "_INAKMES,INFERR=2 Q
  1.  .I INASTAT S INASTAT=1 Q
  1.  .I $E(INASTAT,2)="A" S INASTAT=1 Q
  1.  .I INASTAT="" S INERMSG=$S($L(INERMSG):$E(INERMSG,1,475)_"      ",1:"")_"No ACK status"
  1.  .S INASTAT=0
  1.  I INFERR D ERROR^INHS(INFMSG,INFERR) Q
  1.  D ACKLOG^INHU(INUIF,INAKMES,INASTAT,INERMSG)
  1.  Q
  1.  ;
  1. SETENV ;Set environment for GIS with DUZ postmaster array
  1.  S U="^",DUZ=.5,DUZ(0)="@",IO="",DTIME=1
  1.  ;If Postmaster has no default division, find one and set it.
  1.  ;IHS logic
  1.  I '$$SC^INHUTIL1 D SETDT^UTDT K Z Q
  1.  ;CHCS logic
  1.  I '$P(^DIC(3,DUZ,0),U,16) D SETDIV
  1.  D SETDT^UTDT
  1.  D DUZAG^XUS1   ; set up agency codes, no user prompts
  1.  D ^XUDIV   ; set up division. No user prompts since default div is set
  1.  K Z
  1.  Q
  1.  ;
  1. SETDIV ;Called from SETENV if needed to stuff the postmaster default division.
  1.  N INDEF,INDIV
  1.  S (INDEF,INDIV)=0 F  S INDIV=$O(^DG(40.8,INDIV)) Q:'INDIV!INDEF  D
  1.  .;Set as default if a) an inpatient facility and b) not inactive
  1.  .I $G(^DG(40.8,INDIV,8100)),'$G(^DG(40.8,INDIV,28)) S INDEF=INDIV
  1.  ;If no divisions meet criteria, look for first non active division
  1.  I 'INDEF S INDEV=0 F  S INDIV=$O(^DG(40.8,INDIV)) Q:'INDIV!INDEF  D
  1.  .I '$G(^DG(40.8,INDIV,28)) S INDEF=INDIV
  1.  ;If still no INDEFault, set default to first entry in 40.8
  1.  S:'INDEF INDEF=$O(^DG(40.8,0))
  1.  S DIE="^DIC(3,",DA=.5,DR="28.2///`"_INDEF D ^DIE
  1.  Q
  1.  ;