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

DICU11.m

Go to the documentation of this file.
  1. DICU11 ;SEA/TOAD,SF/TKW-VA FileMan: Lookup Tools, Get IDs & Index ;11/5/99 15:13
  1. ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
  1. ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
  1. ;;Licensed under the terms of the Apache License, Version 2.0.
  1. ;
  1. ; Routines called from DICU1
  1. ;
  1. THROW(DIFLAGS,DIDENT,DIDS,DICRSR,DICOUNT,DIDEFALT,DINDEX,DICF2) ;
  1. ;
  1. ; Build code into DIDENT array to get external field values
  1. ; for indexed fields.
  1. ;
  1. T1 N DIFORMAT D GETFORM(.DIDENT,.DIFORMAT,.DIDS,.DICOUNT)
  1. I DIFORMAT="" S DIFORMAT=DIDEFALT
  1. N DIEXP,DISUB,DISUB0,DIMAP S DISUB0=$S(DIDENT["IX":0,1:DIDENT)
  1. F DISUB=1:1:DINDEX("#") D
  1. . S DIEXP="DINDEX(DISUB)"
  1. . I DIFORMAT="I",DIFLAGS[3,"VP"[DINDEX(DISUB,"TYPE") D
  1. . . I DISUB>1 S DIEXP="DIVAL" Q
  1. . . Q:'$D(DINDEX("ROOTCNG",1))
  1. . . S DIEXP="$G(@DINDEX(1,""ROOT"")@(DINDEX(1)))" Q
  1. . I DIFORMAT="E",$G(DINDEX(DISUB,"GETEXT")) D
  1. . . I DISUB>1,DIFLAGS[4,"VP"[DINDEX(DISUB,"TYPE") S DIEXP="DINDEX(DISUB,""EXT"")" Q
  1. . . I DINDEX(DISUB,"GETEXT")=3 S DIEXP="$$TRANOUT(DISUB,"_DIEXP_")" Q
  1. . . S:DINDEX(DISUB,"GETEXT")=2 DIEXP="DIVAL"
  1. . . S DIEXP=$$FORMAT(DIDENT,DIEXP,0,DIFORMAT,DIDEFALT,DIFLAGS)
  1. . . I DINDEX="B" S DIEXP="$S('$D(DIMNEM):"_DIEXP_",1:DINDEX(DISUB))"
  1. . . Q
  1. . I $G(DICF2) S DIDENT(DICRSR,DISUB0,DISUB,DIFORMAT)=DIEXP Q
  1. . I DIFLAGS["P" S DICRSR=DICRSR+1
  1. . S DIDENT(DICRSR,DISUB0,DISUB,DIFORMAT)=DIEXP
  1. . S DIMAP="IX("_DISUB_")" S:DIFORMAT="I" DIMAP=DIMAP_"I"
  1. . I DIFLAGS["P" S $P(DIDENT(-3),U,DICRSR)=DIMAP Q
  1. . I DIDENT'=-2 S DIDENT(-3,0,DISUB,DIMAP)=""
  1. Q
  1. ;
  1. GETFORM(DIDENT,DIFORMAT,DIDS,DICOUNT) ;
  1. ; Strip E or I off specifier and set into DIFORMAT
  1. N DILENGTH S DILENGTH=$L(DIDENT)
  1. S DIFORMAT=$E(DIDENT,DILENGTH)
  1. I $TR(DIFORMAT,"EI")="" D
  1. . N DIFIRST S DIFIRST=$E(DIDENT,DILENGTH-1) I $TR(DIFIRST,"EI")="" D Q
  1. . . S $E(DIDENT,DILENGTH-1)="",$P(DIDS,";",DICOUNT)=DIDENT
  1. . . S DIFORMAT=DIFIRST,DICOUNT=DICOUNT-1
  1. . . S $E(DIDENT,DILENGTH-1)=""
  1. . S $E(DIDENT,DILENGTH)=""
  1. E S DIFORMAT=""
  1. Q
  1. ;
  1. FORMAT(DIFIELD,DICODE,DIUSEKEY,DIFORMAT,DIDEFALT,DIFLAGS) ;
  1. ; Format fetch code to return either internal or external
  1. N DIFILE S DIFILE="DIFILE"
  1. I DIFIELD'>0 S DIFILE="DINDEX(DISUB,""FILE"")",DIFIELD="DINDEX(DISUB,""FIELD"")"
  1. I DIFORMAT="E" D
  1. . N F S F="""""" I DIFLAGS["h" S F="""h"""
  1. . S DICODE="$$EXTERNAL^DIDU("_DIFILE_","_DIFIELD_","_F_","_DICODE_")"
  1. Q DICODE
  1. ;
  1. WRITEID(DIFILE,DIDENT,DICRSR) ;
  1. ; WRITE Identifiers Loop: add WRITE identifiers to output processor:
  1. ; for WRITE IDs we save the code as is
  1. ;
  1. N DICODE
  1. S DIDENT=$O(^DD(DIFILE,0,"ID"," "),-1),DIDENT=$O(^(DIDENT))
  1. F Q:DIDENT="" D S DIDENT=$O(^DD(DIFILE,0,"ID",DIDENT))
  1. . S DICODE=$G(^DD(DIFILE,0,"ID",DIDENT)) Q:DICODE=""
  1. . I DIFLAGS["P" S DICRSR=DICRSR+1
  1. . S DIDENT(DICRSR,DIDENT,0)="N DIMSG "_DICODE
  1. . S:DIFLAGS["P" $P(DIDENT(-3),U,DICRSR)="WID("_DIDENT_")" Q
  1. Q
  1. ;