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 Dec 13, 2024@02:46:40 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 ;
