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

INHUT11.m

Go to the documentation of this file. 
  1. INHUT11 ; DGH ; 11 Nov 1999 16:13 ; X12 and NCPDP utilities
  1.  ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
  1.  ;COPYRIGHT 1991-2000 SAIC
  1.  ;CHCS TOOLS_460; GEN 1; 17-JUL-1997
  1.  ;COPYRIGHT 1988, 1989, 1990 SAIC
  1.  ;
  1.  ;NO LINETAGS IN THIS ROUTINE ARE SUPPORTED FOR EXECUTION BY ANY
  1.  ;SOFTWARE OUTSIDE THE GIS PACKAGE (IN*)
  1.  Q
  1.  ;
  1. OPIN(X) ;Transform incoming overpunch value
  1.  ;INPUT
  1.  ; NCPDP overpunch value such as 32E or 25}
  1.  ;RETURN
  1.  ; Dollar value in normal format such as 3.50 or -2.50
  1.  ; Negative values will have a minus sign at the start of X
  1.  ; X will be returned with two decimal digits
  1.  ; returns X if invalid format
  1.  ;
  1.  N L,N,S,R
  1.  S R=X,X=$TR(X,"abcdefghijklmnopqr","ABCDEFGHIJKLMNOPQR")
  1.  S L=$L(X),N=$F("{ABCDEFGHI}JKLMNOPQR",$E(X,L))-2,S=""
  1.  Q:N<0 R
  1.  S:N>9 N=N-10,S="-" S $E(X,L)=N
  1.  Q S_$E(X,1,L-2)_"."_$E(X,L-1,L)
  1.  ;
  1. OPOUT(X) ;Transform outgoing dollar value to overpunch value 
  1.  ;INPUT
  1.  ; Dollar value in normal format such as 3.5 or -2.50
  1.  ; three or more decimals are rounded to two
  1.  ; Negative values must have minus sign at the start of X
  1.  ; X does not have to have two decimal digits coming in
  1.  ; 789=789.00, 78.9=78.90, 7.89=7.89, .789=0.79
  1.  ;RETURN
  1.  ; NCPDP overpunch value such as 32E or 25}
  1.  ;
  1.  N L,D,OP
  1.  S X=$J(X,0,2),L=$L(X),D=$E(X,$L(X))+1
  1.  S OP=$S($E(X)="-":$E("}JKLMNOPQR",D),1:$E("{ABCDEFGHI",D))
  1.  S $E(X,L)=OP
  1.  Q $TR(X,"+-.")
  1.  ;
  1. CHKNC(LINE,POS,VAL) ;Identifies an NCPDP segment based on specified values
  1.  ;Called only from within an inbound script.
  1.  ;INPUT:
  1.  ; LINE = Array of INTHU global nodes the comprise a single segment.
  1.  ; POS = Position or starting position in the segment
  1.  ; VAL = A value or a pattern match at that position
  1.  ;       If VAL starts with a "?", assume pattern match.
  1.  ;       Otherwise VAL will be a string of comma-delimited values
  1.  ;RETURN:
  1.  ; 1 = A match was found
  1.  ; 0 = No match
  1.  S:'$G(POS) POS=1 Q:'$L(LINE) 0
  1.  Q:'POS 0
  1.  N MATCH,STR,Z,VAL1
  1.  S MATCH=0
  1.  I $E($G(VAL))'="?" D  Q MATCH
  1.  .;compare $L(VAL) characters begining as POS for exact match
  1.  .F Z=1:1 S VAL1=$P(VAL,",",Z) Q:'$L(VAL1)  D  Q:MATCH
  1.  ..I $E(LINE,POS,(POS+$L(VAL1)-1))=VAL1 S MATCH=1
  1.  ;
  1.  ;Else use pattern match logic
  1.  ;extract from position on
  1.  S STR=$S(POS=1:LINE,1:$E(LINE,POS,$L(LINE)))
  1.  Q @(""""_STR_""""_VAL_$S(VAL'[".ANPC":".ANPC",1:""))
  1.  ;
  1. CHKID(LINE,FLD,VAL) ;Identifies a segment based on specified values
  1.  ;Intended for use for incoming X12 scripts. May not be final design.
  1.  ;INPUT:
  1.  ; LINE = Array of INTHU global nodes the comprise a single segment.
  1.  ; FLD = Field number in the segment
  1.  ; VAL = Array of values that constitute a match
  1.  ;RETURN:
  1.  ; 1 = A match was found
  1.  ; 0 = No match
  1.  N X,Z,ID
  1.  S X=$$PIECE^INHU(.LINE,DELIM,FLD)
  1.  Q:X="" 0
  1.  S (ID,Z)=0 F  S Z=$O(VAL(Z)) Q:'Z  D  Q:ID
  1.  .S:VAL(Z)=X ID=1
  1.  Q $S(ID:1,1:0)
  1.  ;
  1. MEDE ;Sets MEDE header used for NCPDP outgoing messeges
  1.  ;This function is to be called from outgoing M code for the NC MEDE ENP
  1.  ;header segment as defined in the segment section of the message.
  1.  ;It provides a sequence number that is no longer than 8 digits based
  1.  ;on MESSID. $$MESSID^INHD concatenates the 8th field of the Interface 
  1.  ;Site Parameter File (which is normally a MTF code) to a unique 
  1.  ;sequence number. The following function strips the prefix and 
  1.  ;insures that the number will never be more than 8 digits.
  1.  S INA("INSEQ")=$P(MESSID,$P($G(^INRHSITE(1,0)),U,8),2)#10000000
  1.  S INA("INLENGTH")=0
  1.  Q
  1.  ;
  1.  ;
  1. MEDET ;MEDE trailer code
  1.  ;This function is to be called from outgoing M code for the NC MEDE END
  1.  ;segment as defined in the segment section of the message.
  1.  ;The NC MEDE END should be defined to have the highest sequence number,
  1.  ;and will have no fields--only outgoing M code.
  1.  ;This function calculates the length of the NCPCP message and stores
  1.  ;the length in the NC MEDE HEADER, ^UTILITY("INH",$J,1).
  1.  N INL,LEN,STR
  1.  S LEN=$$CALCLEN^INHUT11("^UTILITY(""INH"",$J)")
  1.  ;Pad with zeros to a total length of 4
  1.  S INL=$TR($J(LEN,4)," ",0)
  1.  ;Insert in UTILITY in positions 21 through 24.
  1.  S STR=^UTILITY("INH",$J,1)
  1.  S ^UTILITY("INH",$J,1)=$E(STR,1,20)_INL_$E(STR,25,$L(STR))
  1.  Q
  1. CALCLEN(G) ;Calculate the length of the NCPDP portion of the message
  1.  ;Called from an outgoing script in the END section after all
  1.  ;segments have been built and stored in ^UTILITY("INH",$J,line)
  1.  ;
  1.  N LEN,I,C,J
  1.  ;Start counting from I=1 because MEDE header is in ^UTILITY(..,1)
  1.  ;and it's length is not to be included in NCP count.
  1.  S (LEN,C)=0,I=1
  1.  F  S I=$O(@G@(I)) Q:'I  D
  1.  .S C=C+1,LEN=LEN+$L(@G@(I))
  1.  .I $O(@G@(I,0)) D
  1.  ..;go through all overflow nodes
  1.  .. S J=0 F  S J=$O(@G@(I,J)) Q:'J  S C=C+1,LEN=LEN+$L(@G@(I,J))
  1.  .;add 1 byte for segment terminator
  1.  .S LEN=LEN+1
  1.  ;Decrement by 1 because last NCPDP group won't have segment terminator
  1.  Q (LEN-1)
  1.  ;
  1.  ;
  1. XREF ;Store SEQ in .17 field and set x-ref.
  1.  ;This tag is called at end of script after it has called NEWO^INHD.
  1.  ;INPUT:
  1.  ; UIF is a state variable if NEWO^INHD was successful
  1.  ; INDEST is a state variable inside the script
  1.  ; INA("INSEQ")=sequence number
  1.  Q:'$D(UIF)
  1.  N INSEQ S INSEQ=+$G(INA("INSEQ")) Q:'INSEQ
  1.  S $P(^INTHU(UIF,0),U,17)=INSEQ,^INTHU("ASEQ",INDEST,INSEQ,UIF)=""
  1.  Q:$G(INSTD)="X12"
  1.  ;Following x-ref only used by NCPDP transceiver
  1.  S ^INTHU("ASEQ1",INDEST,UIF,INSEQ)=""
  1.  Q
  1.  ;
  1.  ; THIS WILL CHECK FOR THE CASE $D(LINE)=1 or 10 or 11
  1.  ; For example: $D(LINE)=11
  1.  ; LINE="PID^A^B^^^^^^^^^"
  1.  ; LINE(1)="THIS IS LINE1 ^^^^^"
  1.  ; LINE(2)="THIS IS LINE2^^^^^^^^^^"
  1.  ;
  1. LINE(%L,%D,LCT) ;Suppress trailing null fields and suppress null segs
  1.  ; %L = Line array to be stripped (PBR)
  1.  ; %D = delimiter
  1.  ; LCT = current number of line
  1.  ;
  1.  N I,J,CNT,N,TLCT,ORGL
  1.  S %L=$G(%L),%D=$G(%D),TLCT=LCT
  1.  ; Check overflow and number of overflow line
  1.  F J=0:1 Q:'$D(%L(J+1))
  1.  N EMPTY,CKOUT S (CKOUT,EMPTY)=0
  1.  ;Go through each overflow line
  1.  I J F N=J:-1:1 D  Q:'N!CKOUT
  1.  .N STOP
  1.  .F I=$L(%L(N)):-1:1 D  Q:CKOUT
  1.  .. S STOP=$E(%L(N),I)
  1.  .. I I=1,STOP="^" S TLCT=TLCT-1 K %L(N)
  1.  ..I STOP'["^" S CKOUT=1,%L(N)=$E(%L(N),1,I)
  1.  .;EMPTY=1 means lines in array have been checked
  1.  .;and these lines are empty e.g LINE(1)=^^^^^^^,LINE(2)=^^^^^^^,...
  1.  .I (N=1),(LCT-TLCT=J) S EMPTY=1,J=0
  1.  ;Check the case that has no overflow node e.g LINE=a^^^^
  1.  ;or has overflow node but the array lines are empty
  1.  I 'J,$L(%L) D
  1.  .S CNT=$L(%L,%D)
  1.  .F I=CNT:-1:1 S A(I)=$$TB^UTIL($P(%L,%D,I)) Q:$G(A(I))'=""
  1.  .S ORGL=$P(%L,%D,1),%L=$E(%L,1,$$TOTL(I,%L,%D))
  1.  ; If all lines are empty then decrease segment count and line count by 1
  1.  I $G(%L)=$G(ORGL),(EMPTY!('EMPTY&($D(%L)<9))) S %L="",LCT=LCT-1
  1.  Q
  1.  ;
  1. TOTL(I,%L,%D) ;Calculate the length of valid fields
  1.  N CNTL,K
  1.  S CNTL=0
  1.  F K=1:1:I S B(K)=$L($P(%L,%D,K)),CNTL=CNTL+B(K)
  1.  S CNTL=CNTL+I-1
  1.  Q CNTL
  1.  ;
  1. X1DATE() ;This is check for the X12 date stamp
  1.  ; This function is obsolete. - ld
  1.  N YRCOMP
  1.  S YRCOMP=$E(DT,2,3)-$E($G(X),1,2)
  1.  ; 2000 - 1999  e.g 00 - 99 = -99
  1.  Q:YRCOMP<-50 ($E(DT)-1)_X
  1.  ; 1999 - 2000 e.g 99 - 00= 99
  1.  Q:YRCOMP>50 ($E(DT)+1)_X
  1.  ; Use current century
  1.  Q:$E(DT)_X
  1.  ;