- DICU11 ;SEA/TOAD,SF/TKW-VA FileMan: Lookup Tools, Get IDs & Index ;11/5/99 15:13
- ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
- ;;Per VA Directive 6402, this routine should not be modified.
- ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- ;;Licensed under the terms of the Apache License, Version 2.0.
- ;
- ; Routines called from DICU1
- ;
- THROW(DIFLAGS,DIDENT,DIDS,DICRSR,DICOUNT,DIDEFALT,DINDEX,DICF2) ;
- ;
- ; Build code into DIDENT array to get external field values
- ; for indexed fields.
- ;
- T1 N DIFORMAT D GETFORM(.DIDENT,.DIFORMAT,.DIDS,.DICOUNT)
- I DIFORMAT="" S DIFORMAT=DIDEFALT
- N DIEXP,DISUB,DISUB0,DIMAP S DISUB0=$S(DIDENT["IX":0,1:DIDENT)
- F DISUB=1:1:DINDEX("#") D
- . S DIEXP="DINDEX(DISUB)"
- . I DIFORMAT="I",DIFLAGS[3,"VP"[DINDEX(DISUB,"TYPE") D
- . . I DISUB>1 S DIEXP="DIVAL" Q
- . . Q:'$D(DINDEX("ROOTCNG",1))
- . . S DIEXP="$G(@DINDEX(1,""ROOT"")@(DINDEX(1)))" Q
- . I DIFORMAT="E",$G(DINDEX(DISUB,"GETEXT")) D
- . . I DISUB>1,DIFLAGS[4,"VP"[DINDEX(DISUB,"TYPE") S DIEXP="DINDEX(DISUB,""EXT"")" Q
- . . I DINDEX(DISUB,"GETEXT")=3 S DIEXP="$$TRANOUT(DISUB,"_DIEXP_")" Q
- . . S:DINDEX(DISUB,"GETEXT")=2 DIEXP="DIVAL"
- . . S DIEXP=$$FORMAT(DIDENT,DIEXP,0,DIFORMAT,DIDEFALT,DIFLAGS)
- . . I DINDEX="B" S DIEXP="$S('$D(DIMNEM):"_DIEXP_",1:DINDEX(DISUB))"
- . . Q
- . I $G(DICF2) S DIDENT(DICRSR,DISUB0,DISUB,DIFORMAT)=DIEXP Q
- . I DIFLAGS["P" S DICRSR=DICRSR+1
- . S DIDENT(DICRSR,DISUB0,DISUB,DIFORMAT)=DIEXP
- . S DIMAP="IX("_DISUB_")" S:DIFORMAT="I" DIMAP=DIMAP_"I"
- . I DIFLAGS["P" S $P(DIDENT(-3),U,DICRSR)=DIMAP Q
- . I DIDENT'=-2 S DIDENT(-3,0,DISUB,DIMAP)=""
- Q
- ;
- GETFORM(DIDENT,DIFORMAT,DIDS,DICOUNT) ;
- ; Strip E or I off specifier and set into DIFORMAT
- N DILENGTH S DILENGTH=$L(DIDENT)
- S DIFORMAT=$E(DIDENT,DILENGTH)
- I $TR(DIFORMAT,"EI")="" D
- . N DIFIRST S DIFIRST=$E(DIDENT,DILENGTH-1) I $TR(DIFIRST,"EI")="" D Q
- . . S $E(DIDENT,DILENGTH-1)="",$P(DIDS,";",DICOUNT)=DIDENT
- . . S DIFORMAT=DIFIRST,DICOUNT=DICOUNT-1
- . . S $E(DIDENT,DILENGTH-1)=""
- . S $E(DIDENT,DILENGTH)=""
- E S DIFORMAT=""
- Q
- ;
- FORMAT(DIFIELD,DICODE,DIUSEKEY,DIFORMAT,DIDEFALT,DIFLAGS) ;
- ; Format fetch code to return either internal or external
- N DIFILE S DIFILE="DIFILE"
- I DIFIELD'>0 S DIFILE="DINDEX(DISUB,""FILE"")",DIFIELD="DINDEX(DISUB,""FIELD"")"
- I DIFORMAT="E" D
- . N F S F="""""" I DIFLAGS["h" S F="""h"""
- . S DICODE="$$EXTERNAL^DIDU("_DIFILE_","_DIFIELD_","_F_","_DICODE_")"
- Q DICODE
- ;
- WRITEID(DIFILE,DIDENT,DICRSR) ;
- ; WRITE Identifiers Loop: add WRITE identifiers to output processor:
- ; for WRITE IDs we save the code as is
- ;
- N DICODE
- S DIDENT=$O(^DD(DIFILE,0,"ID"," "),-1),DIDENT=$O(^(DIDENT))
- F Q:DIDENT="" D S DIDENT=$O(^DD(DIFILE,0,"ID",DIDENT))
- . S DICODE=$G(^DD(DIFILE,0,"ID",DIDENT)) Q:DICODE=""
- . I DIFLAGS["P" S DICRSR=DICRSR+1
- . S DIDENT(DICRSR,DIDENT,0)="N DIMSG "_DICODE
- . S:DIFLAGS["P" $P(DIDENT(-3),U,DICRSR)="WID("_DIDENT_")" Q
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICU11 3026 printed Jan 18, 2025@03:47:38 Page 2
- 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
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- +4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- +5 ;;Licensed under the terms of the Apache License, Version 2.0.
- +6 ;
- +7 ; Routines called from DICU1
- +8 ;
- THROW(DIFLAGS,DIDENT,DIDS,DICRSR,DICOUNT,DIDEFALT,DINDEX,DICF2) ;
- +1 ;
- +2 ; Build code into DIDENT array to get external field values
- +3 ; for indexed fields.
- +4 ;
- T1 NEW DIFORMAT
- DO GETFORM(.DIDENT,.DIFORMAT,.DIDS,.DICOUNT)
- +1 IF DIFORMAT=""
- SET DIFORMAT=DIDEFALT
- +2 NEW DIEXP,DISUB,DISUB0,DIMAP
- SET DISUB0=$SELECT(DIDENT["IX":0,1:DIDENT)
- +3 FOR DISUB=1:1:DINDEX("#")
- Begin DoDot:1
- +4 SET DIEXP="DINDEX(DISUB)"
- +5 IF DIFORMAT="I"
- IF DIFLAGS[3
- IF "VP"[DINDEX(DISUB,"TYPE")
- Begin DoDot:2
- +6 IF DISUB>1
- SET DIEXP="DIVAL"
- QUIT
- +7 if '$DATA(DINDEX("ROOTCNG",1))
- QUIT
- +8 SET DIEXP="$G(@DINDEX(1,""ROOT"")@(DINDEX(1)))"
- QUIT
- End DoDot:2
- +9 IF DIFORMAT="E"
- IF $GET(DINDEX(DISUB,"GETEXT"))
- Begin DoDot:2
- +10 IF DISUB>1
- IF DIFLAGS[4
- IF "VP"[DINDEX(DISUB,"TYPE")
- SET DIEXP="DINDEX(DISUB,""EXT"")"
- QUIT
- +11 IF DINDEX(DISUB,"GETEXT")=3
- SET DIEXP="$$TRANOUT(DISUB,"_DIEXP_")"
- QUIT
- +12 if DINDEX(DISUB,"GETEXT")=2
- SET DIEXP="DIVAL"
- +13 SET DIEXP=$$FORMAT(DIDENT,DIEXP,0,DIFORMAT,DIDEFALT,DIFLAGS)
- +14 IF DINDEX="B"
- SET DIEXP="$S('$D(DIMNEM):"_DIEXP_",1:DINDEX(DISUB))"
- +15 QUIT
- End DoDot:2
- +16 IF $GET(DICF2)
- SET DIDENT(DICRSR,DISUB0,DISUB,DIFORMAT)=DIEXP
- QUIT
- +17 IF DIFLAGS["P"
- SET DICRSR=DICRSR+1
- +18 SET DIDENT(DICRSR,DISUB0,DISUB,DIFORMAT)=DIEXP
- +19 SET DIMAP="IX("_DISUB_")"
- if DIFORMAT="I"
- SET DIMAP=DIMAP_"I"
- +20 IF DIFLAGS["P"
- SET $PIECE(DIDENT(-3),U,DICRSR)=DIMAP
- QUIT
- +21 IF DIDENT'=-2
- SET DIDENT(-3,0,DISUB,DIMAP)=""
- End DoDot:1
- +22 QUIT
- +23 ;
- GETFORM(DIDENT,DIFORMAT,DIDS,DICOUNT) ;
- +1 ; Strip E or I off specifier and set into DIFORMAT
- +2 NEW DILENGTH
- SET DILENGTH=$LENGTH(DIDENT)
- +3 SET DIFORMAT=$EXTRACT(DIDENT,DILENGTH)
- +4 IF $TRANSLATE(DIFORMAT,"EI")=""
- Begin DoDot:1
- +5 NEW DIFIRST
- SET DIFIRST=$EXTRACT(DIDENT,DILENGTH-1)
- IF $TRANSLATE(DIFIRST,"EI")=""
- Begin DoDot:2
- +6 SET $EXTRACT(DIDENT,DILENGTH-1)=""
- SET $PIECE(DIDS,";",DICOUNT)=DIDENT
- +7 SET DIFORMAT=DIFIRST
- SET DICOUNT=DICOUNT-1
- +8 SET $EXTRACT(DIDENT,DILENGTH-1)=""
- End DoDot:2
- QUIT
- +9 SET $EXTRACT(DIDENT,DILENGTH)=""
- End DoDot:1
- +10 IF '$TEST
- SET DIFORMAT=""
- +11 QUIT
- +12 ;
- FORMAT(DIFIELD,DICODE,DIUSEKEY,DIFORMAT,DIDEFALT,DIFLAGS) ;
- +1 ; Format fetch code to return either internal or external
- +2 NEW DIFILE
- SET DIFILE="DIFILE"
- +3 IF DIFIELD'>0
- SET DIFILE="DINDEX(DISUB,""FILE"")"
- SET DIFIELD="DINDEX(DISUB,""FIELD"")"
- +4 IF DIFORMAT="E"
- Begin DoDot:1
- +5 NEW F
- SET F=""""""
- IF DIFLAGS["h"
- SET F="""h"""
- +6 SET DICODE="$$EXTERNAL^DIDU("_DIFILE_","_DIFIELD_","_F_","_DICODE_")"
- End DoDot:1
- +7 QUIT DICODE
- +8 ;
- WRITEID(DIFILE,DIDENT,DICRSR) ;
- +1 ; WRITE Identifiers Loop: add WRITE identifiers to output processor:
- +2 ; for WRITE IDs we save the code as is
- +3 ;
- +4 NEW DICODE
- +5 SET DIDENT=$ORDER(^DD(DIFILE,0,"ID"," "),-1)
- SET DIDENT=$ORDER(^(DIDENT))
- +6 FOR
- if DIDENT=""
- QUIT
- Begin DoDot:1
- +7 SET DICODE=$GET(^DD(DIFILE,0,"ID",DIDENT))
- if DICODE=""
- QUIT
- +8 IF DIFLAGS["P"
- SET DICRSR=DICRSR+1
- +9 SET DIDENT(DICRSR,DIDENT,0)="N DIMSG "_DICODE
- +10 if DIFLAGS["P"
- SET $PIECE(DIDENT(-3),U,DICRSR)="WID("_DIDENT_")"
- QUIT
- End DoDot:1
- SET DIDENT=$ORDER(^DD(DIFILE,0,"ID",DIDENT))
- +11 QUIT
- +12 ;