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

INHSZ2.m

Go to the documentation of this file. 
  1. INHSZ2 ;JSH,DGH; 15 Oct 1999 15:50 ;Script compiler DATA section handler ; 11 Nov 91   6:42 AM 
  1.  ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
  1.  ;COPYRIGHT 1991-2000 SAIC
  1.  ;CHCS TOOLS_460; GEN 4; 4-SEP-1997
  1.  ;COPYRIGHT 1988, 1989, 1990 SAIC
  1.  ;
  1. L G L^INHSZ1
  1.  ;
  1. IN ;Enter code
  1.  Q
  1.  ;
  1. OUT ;Exit code
  1.  S A=" D:'INVS MC^INHS" D L
  1.  Q
  1.  ;
  1. DATA ;Handle lines in DATA section
  1.  ;Enter here with LINE array set to current line
  1.  ;Get command
  1.  N COMM
  1.  S COMM=$P($TR(LINE,"=(","  ")," ") I '$$CMD^INHSZ1(COMM,"ERROR^SUBDELIM^DELIM^SET^LINE^WHILE^ENDWHILE^TEMPLATE^GROUP^ENDGROUP^IF^ENDIF^SCREEN^BHLMIEN") D ERROR^INHSZ0("Invalid command in DATA section.",1) Q  ;cmi/maw added BHLMIEN
  1.  S X=$$CASECONV^UTIL(COMM,"U") G:$T(@X)]"" @X
  1.  G @(X_"^INHSZ21")
  1.  ;
  1. TEMPLATE ;Invoke a print template to generate lines
  1.  G TEMPLATE^INHSZ20
  1.  ;
  1. LINE ;LINE statement
  1.  N %1,I,%2,V,F,POS,LC,OUT,P,%0,PM,W
  1.  S %1=$$LB^UTIL($P(LINE," ",2,999)),LC=0,OUT=0,%0=$P(LINE," ")
  1.  I INSTD="NC",%1["NCID" D LINENC^INHSZ23 Q
  1.  I MODE="O" Q:'$$SYNTAX^INHSZ0(%1,"1.ANP")
  1.  I %0["(",MODE="O" D ERROR^INHSZ0("Pattern check only allowed in INPUT mode.",1) Q
  1.  I %0["(" Q:'$$SYNTAX^INHSZ0($P(%0,"LINE",2),"1""(""1.ANP1"")""")
  1.  S PM=$P($P(%0,"(",2),")")
  1.  S A=" D:'INVS MC^INHS" D L
  1.  G LINEO^INHSZ20:MODE="O"
  1. LINEI ;Input mode
  1.  S A=" D GET^INHOU(UIF,0) S LINE=$G(LINE),DO="_'GROUP D L S POS=1
  1.  ; Initial lookup/processing logic for segment. PM is null at this point.
  1.  I PM]"" D
  1.  . I INSTD="NC",$G(INIDF) D  Q
  1.  .. S WHPRE=""""""_$TR(PM,"*","")_""""","
  1.  .. S A=" I 'MATCH,$$CHKNC^INHUT11(.LINE,"_INIDF_","""_INIDV_""") S DO=1,MATCH=1" D L
  1.  .. S A=" E  S LCT=LCT-CNT,DO=0" D L
  1.  . S A=" I "_$S(GROUP:"'MATCH,",1:"")_"LINE?"_$$PMTO(PM)_" S DO=1"_$S(GROUP:",MATCH=1",1:"") D L
  1.  . S A=" E  S LCT=LCT-CNT,DO=0" D L
  1.  ;Loop through all fields in LINE and create extraction logic for each
  1.  S I=1,P=0 F  D  Q:ER!OUT  S I=I+1,P=P+1
  1.  . ;Determine type of field
  1.  . I I=$L(%1,"^"),$O(LINE(LC)) S LC=LC+1,%1=$P(%1,"^",I)_LINE(LC),I=1
  1.  . S %2=$P(%1,"^",I),V=$$LBTB^UTIL($P(%2,"=")),F=$$LBTB^UTIL($P(%2,"=",2)) K V(0)
  1.  . I I>$L(%1,"^")!(I=$L(%1,"^")&(%2="")) S OUT=1 Q
  1.  . Q:V=""  S:F="" F="V"
  1.  . I INSTD="NC"&('$G(INIDF)!'$L($G(INIDV))) D ERROR^INHSZ0("NCPDP segment "_$G(PM)_" must have an ID FIELD and an ID VALUE") Q
  1.  . I '$$FORMAT(F) D ERROR^INHSZ0("Illegal format: '"_F_"'",1) Q
  1.  . I V'["," D  Q:ER
  1.  .. ;I $D(DICOMPX(V)) D WARN^INHSZ0("Duplicate Variable Usage: '"_V_"'",1)
  1.  .. S DICOMPX(V)="$G(@INV@("""_V_"""))" S:WHILE LVARS(V)=WHILE
  1.  . I V["," S V(0)=V D  Q:V=""
  1.  .. F K=$L(V(0),","):-1:0 Q:'K  Q:$$LBTB^UTIL($P(V(0),",",K))]""
  1.  .. S V="" S:K V=$$LBTB^UTIL($P(V(0),",",K))
  1.  . ;--Extraction logic for variable-length fields.
  1.  . I $E(F)="V" D  Q:ER
  1.  .. I 'DELIM D ERROR^INHSZ0("Delimiter not defined.  Cannot interpret a variable field.",1) Q
  1.  ..;NCPDP variable fields are at end of LINE and must be recognized by last two characters of field id--but stored with full identifier.
  1.  .. I $G(INSTD)="NC" S A=" I DO F I=2:1 S X=$$PIECE^INHU(.LINE,DELIM,I) Q:'$L(X)  S:$E(X,1,2)="""_$E(V,$L(V)-1,$L(V))_""" @(""@INV@("_WHPRE_""""""_V_""""""_WHSUB_")"")=$E(X,3,$L(X))" D L Q
  1.  .. I $E(V,1,3)'="MSH" S A=" S:DO @(""@INV@("""""_V_""""""_WHSUB_")"")=$$PIECE^INHU(.LINE,DELIM,"_(P+1)_")" D L Q
  1.  .. ; MSH line 1 set to delimeter
  1.  .. I $E(V,1,3)="MSH",P=1 S A=" S:DO @(""@INV@("""""_V_""""""_WHSUB_")"")=$E($G(LINE),4)" D L Q
  1.  .. ; MSH line everything else
  1.  .. S A=" S:DO @(""@INV@("""""_V_""""""_WHSUB_")"")=$$PIECE^INHU(.LINE,DELIM,"_P_")" D L Q
  1.  . ;--Extraction logic for fixed-length fields.
  1.  . I $E(F)="F" D
  1.  .. ;--Fixed length logic is not currently specific to data types
  1.  .. ;--In the future, it may be necessary to handle numeric fields
  1.  .. ;--differently than alpha because the logic that strips pad
  1.  .. ;--characters (variable PD) leaves 0000 equal to "", which
  1.  .. ;--fails the required field check downstream.
  1.  .. S PC=$P($P(F,"(",2),")")
  1.  .. S A=" S:DO X=$$EXTRACT^INHU(.LINE,"_POS_","_(POS+$P(F,")",2)-1)_")",POS=POS+$P(F,")",2) D L
  1.  .. ;For NCPCP, variable WHPRE is used to fully subscript the INV
  1.  .. ;array into the nest. This may also work for X12. The NCPDP
  1.  .. ;logic would work for HL7 if WHPRE is set to null, but needs
  1.  .. ;extensive testing before replacing HL7 logic.
  1.  .. I $G(INSTD)="NC" D  Q
  1.  ... I PC="" S A=" S:DO @(""@INV@("_WHPRE_""""""_V_""""""_WHSUB_")"")=X" D L Q
  1.  ... S:"Rr"[$E(F,2) A=" I DO F I=1:1:$L(X) " S:"Ll"[$E(F,2) A=" I DO F I=$L(X):-1:1 " S A=A_"Q:$E(X,I)'="""_PC_"""" D L
  1.  ... I "Ll"[$E(F,2) S A=" S:DO @(""@INV@("_WHPRE_""""""_V_""""""_WHSUB_")"")=$E(X,1,$S($E(X,I)'="""_PC_""":I,1:0))" D L
  1.  ... I "Rr"[$E(F,2) S A=" S:DO @(""@INV@("_WHPRE_""""""_V_""""""_WHSUB_")"")=$E(X,$S($E(X,I)'="""_PC_""":I,1:I+1),$L(X))" D L
  1.  ...;----end of NCPDP logic
  1.  .. I PC="" S A=" S:DO @(""@INV@("""""_V_""""""_WHSUB_")"")=X" D L Q
  1.  .. S:"Rr"[$E(F,2) A=" I DO F I=1:1:$L(X) " S:"Ll"[$E(F,2) A=" I DO F I=$L(X):-1:1 " S A=A_"Q:$E(X,I)'="""_PC_"""" D L
  1.  .. I "Ll"[$E(F,2) S A=" S:DO @(""@INV@("""""_V_""""""_WHSUB_")"")=$E(X,1,$S($E(X,I)'="""_PC_""":I,1:0))" D L
  1.  .. I "Rr"[$E(F,2) S A=" S:DO @(""@INV@("""""_V_""""""_WHSUB_")"")=$E(X,$S($E(X,I)'="""_PC_""":I,1:I+1),$L(X))" D L
  1.  . I $D(V(0)) D
  1.  .. I 'SUBDELIM D ERROR^INHSZ0("Sub-delimiter not defined.",1) Q
  1.  .. N I
  1.  .. F I=1:1:$L(V(0),",") S V1=$$LBTB^UTIL($P(V(0),",",I)) Q:V1=""  D  Q:ER
  1.  ... ;I $D(DICOMPX(V1)) D WARN^INHSZ0("Duplicate Variable Usage: '"_V1_"'",1)
  1.  ... S A=" S:DO @(""@INV@("""""_V1_""""""_WHSUB_")"")=$P(@(""@INV@("""""_V_""""""_WHSUB_")""),SUBDELIM,"_I_")" D L S DICOMPX(V1)="$G(@INV@("""_V1_"""))" S:WHILE LVARS(V1)=WHILE
  1.  I GROUP S A=" Q:MATCH" D L
  1.  K INIDF,INIDV
  1.  Q
  1.  ;
  1. FORMAT(%F) ;Check format string (Modified 6/1/95 to support M and V)
  1.  ;%F = string to verify    Function returns 1 if OK, 0 otherwise
  1.  ;Allowable formats are F=fixed, V=Variable, M=Minimum/Maximum
  1.  N ER,MIN
  1.  I "FVfvMm"'[$E(%F) Q 0
  1.  ;NCPDP format for V allows more than single character
  1.  I "Vv"[$E(%F),$G(INSTD)="NC" Q 1
  1.  S ER=0 I "Vv"[$E(%F) Q $S($L(%F)>1:0,1:1)
  1.  I %F["," S MIN=$P(%F,",",2),%F=$P(%F,",")
  1.  I $E(%F,2,999)'?1A1"(".1ANP1")"1.N!("LRlr"'[$E(%F,2)) Q 0
  1.  I $D(MIN),MIN'?.N Q 0
  1.  Q 1
  1.  ;
  1.  ;
  1. PMTO(%P) ;Convert Script Pattern string to MUMPS Pattern Match equivalent
  1.  ;%P = script pattern
  1.  ;Function returns MUMPS equivalent or "" if an error occured
  1.  I %P="*" Q "1.E"
  1.  N PAT,POS,C
  1.  S PAT="" F I=1:1:$L(%P) S C=$E(%P,I) D
  1.  . ;Following pattern matches changed from ANP to ANPC to meet
  1.  . ;PWS need to have control characters in ZIL segment. This may not
  1.  . ;be a permanent solution
  1.  . I C="*" S PAT=PAT_".ANPC" Q
  1.  . I C="?" S PAT=PAT_"1ANPC" Q
  1.  . S PAT=PAT_"1"""_C_"""" Q
  1.  Q PAT
  1.  ;
  1. SCREEN G SCREEN^INHSZ20