- DICU ;SEA/TOAD-VA FileMan: Lookup Utilities ;12APR2008
- ;;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.
- ;
- REQIDS(DIFILE,DITARGET) ;
- ; return REQUIRED IDENTIFIERS file attribute
- ; DIFILE = file#, DITARGET = target array
- N DIATTRBT S DIATTRBT="REQUIRED IDENTIFIERS"
- S @DITARGET@(DIATTRBT,.01)=""
- N DIFIELD
- S DIFIELD=0 F S DIFIELD=$O(^DD(DIFILE,0,"ID",DIFIELD)) Q:'DIFIELD D
- . I $D(^DD(DIFILE,"RQ",DIFIELD)) S @DITARGET@(DIATTRBT,DIFIELD)=""
- Q
- ;
- RID(DIFILE) ;
- ; return a string listing a file's required identifiers
- ; DIFILE = file#
- N DILIST S DILIST=".01"
- N DID S DID="" F S DID=$O(^DD(DIFILE,0,"ID",DID)) Q:'DID D
- . I $D(^DD(DIFILE,"RQ",DID)) S DILIST=DILIST_U_DID
- Q DILIST
- ;
- RECALL(DIFILE,DIEN,DIUSER) ;
- RECALLX ; input from DILFD
- ;
- ; ENTRY POINT--save a user's selection for use with space-bar recall
- ; procedure, all passed by value
- ;
- I '$D(DIQUIET) N DIQUIET S DIQUIET=1
- I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
- N DICLERR S DICLERR=$G(DIERR) K DIERR
- ;
- 30 S DIFILE=$G(DIFILE)
- I +DIFILE'=DIFILE!(DIFILE<0) D ERR(202,"","","","file") Q
- S DIEN=$G(DIEN) I DIEN="" S DIEN=","
- I '$$IEN^DIDU1(DIEN) D ERR(202,"","","","IEN string") Q
- S DIUSER=+$G(DIUSER)
- ;
- 32 N DIOROOT,DIOUT S DIOUT=0 D I DIOUT Q
- . I '$D(^DD(DIFILE)) D ERR(401,DIFILE) S DIOUT=1 Q
- . S DIOROOT=$$ROOT^DILFD(DIFILE,DIEN,"Q")
- . I DIOROOT'?1"^"1.7AN1"(".ANP,DIOROOT'?1"^%".7AN1"(".ANP D Q ;JIM SELF --ALLOW LC GLOBAL NAMES
- . . D ERR(402,DIFILE,"","","","","",DIOROOT) S DIOUT=1
- S ^DISV(DIUSER,$E(DIOROOT,1,28))=$E(DIOROOT,29,$L(DIOROOT))_+DIEN
- I DICLERR'=""!$G(DIERR) D
- . S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2))
- Q
- ;
- FILE(DIFILE,DIDA,DIFLAGS,DIROOT) ;
- ; entry point -- given a root, calculate the file # and DA
- ; DO NOT USE UNTIL $QS & $QL AVAILABLE
- N DIGLOBAL I $G(DIFLAGS)'["O" S DIGLOBAL=DIROOT
- E S DIGLOBAL=$$CREF^DIQGU(DIROOT),DIROOT=DIGLOBAL
- S DIFILE=+$P($G(@DIGLOBAL@(0)),U,2),DIDA=""
- N DA,DIENTRY S DA=1,DIENTRY=0
- ;
- LOOP N DICHAR,DIL,DILEAD,DIQL,DIQS,DIQSL F D Q:'DIQL
- .
- STRIP .
- . ; S DIQL=$QL(DIGLOBAL) Q:'DIQL
- . ; S DIQS=$QS(DIGLOBAL,DIQL)
- . N DIQSL S DIQSL=$L(DIQS)+1 I +DIQS'=DIQS S DIQSL=DIQSL+2
- . S DIL=$L(DIGLOBAL),DILEAD=DIL-DIQSL
- . S $E(DIGLOBAL,DILEAD+1,DIL-1)=""
- . S DICHAR=$E(DIGLOBAL,DILEAD)
- . I DICHAR="," S $E(DIGLOBAL,DILEAD)=""
- . E I DICHAR="(" S $E(DIGLOBAL,DILEAD,DILEAD+1)=""
- . E S DIGLOBAL="ERROR: "_DIGLOBAL,DIQL=0
- .
- ENTRY . I DIENTRY D
- . . S DIFILE(DA)=+$P($G(@DIGLOBAL@(0)),U,2)
- . . S DIROOT(DA)=DIGLOBAL
- . . S DIDA(DA)=DIQS,DA=DA+1
- . S DIENTRY='DIENTRY
- Q
- ;
- ERR(DIERN,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3,DIROOT) ;
- ;
- ; error logging procedure
- ; RECALL
- ;
- N DIPE,DI
- F DI="FILE","IENS","FIELD",1:1:3,"ROOT" S DIPE(DI)=$G(@("DI"_DI))
- D BLD^DIALOG(DIERN,.DIPE,.DIPE)
- S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2))
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICU 3166 printed Jan 18, 2025@03:47:36 Page 2
- DICU ;SEA/TOAD-VA FileMan: Lookup Utilities ;12APR2008
- +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 ;
- REQIDS(DIFILE,DITARGET) ;
- +1 ; return REQUIRED IDENTIFIERS file attribute
- +2 ; DIFILE = file#, DITARGET = target array
- +3 NEW DIATTRBT
- SET DIATTRBT="REQUIRED IDENTIFIERS"
- +4 SET @DITARGET@(DIATTRBT,.01)=""
- +5 NEW DIFIELD
- +6 SET DIFIELD=0
- FOR
- SET DIFIELD=$ORDER(^DD(DIFILE,0,"ID",DIFIELD))
- if 'DIFIELD
- QUIT
- Begin DoDot:1
- +7 IF $DATA(^DD(DIFILE,"RQ",DIFIELD))
- SET @DITARGET@(DIATTRBT,DIFIELD)=""
- End DoDot:1
- +8 QUIT
- +9 ;
- RID(DIFILE) ;
- +1 ; return a string listing a file's required identifiers
- +2 ; DIFILE = file#
- +3 NEW DILIST
- SET DILIST=".01"
- +4 NEW DID
- SET DID=""
- FOR
- SET DID=$ORDER(^DD(DIFILE,0,"ID",DID))
- if 'DID
- QUIT
- Begin DoDot:1
- +5 IF $DATA(^DD(DIFILE,"RQ",DID))
- SET DILIST=DILIST_U_DID
- End DoDot:1
- +6 QUIT DILIST
- +7 ;
- RECALL(DIFILE,DIEN,DIUSER) ;
- RECALLX ; input from DILFD
- +1 ;
- +2 ; ENTRY POINT--save a user's selection for use with space-bar recall
- +3 ; procedure, all passed by value
- +4 ;
- +5 IF '$DATA(DIQUIET)
- NEW DIQUIET
- SET DIQUIET=1
- +6 IF '$DATA(DIFM)
- NEW DIFM
- SET DIFM=1
- DO INIZE^DIEFU
- +7 NEW DICLERR
- SET DICLERR=$GET(DIERR)
- KILL DIERR
- +8 ;
- 30 SET DIFILE=$GET(DIFILE)
- +1 IF +DIFILE'=DIFILE!(DIFILE<0)
- DO ERR(202,"","","","file")
- QUIT
- +2 SET DIEN=$GET(DIEN)
- IF DIEN=""
- SET DIEN=","
- +3 IF '$$IEN^DIDU1(DIEN)
- DO ERR(202,"","","","IEN string")
- QUIT
- +4 SET DIUSER=+$GET(DIUSER)
- +5 ;
- 32 NEW DIOROOT,DIOUT
- SET DIOUT=0
- Begin DoDot:1
- +1 IF '$DATA(^DD(DIFILE))
- DO ERR(401,DIFILE)
- SET DIOUT=1
- QUIT
- +2 SET DIOROOT=$$ROOT^DILFD(DIFILE,DIEN,"Q")
- +3 ;JIM SELF --ALLOW LC GLOBAL NAMES
- IF DIOROOT'?1"^"1.7AN1"(".ANP
- IF DIOROOT'?1"^%".7AN1"(".ANP
- Begin DoDot:2
- +4 DO ERR(402,DIFILE,"","","","","",DIOROOT)
- SET DIOUT=1
- End DoDot:2
- QUIT
- End DoDot:1
- IF DIOUT
- QUIT
- +5 SET ^DISV(DIUSER,$EXTRACT(DIOROOT,1,28))=$EXTRACT(DIOROOT,29,$LENGTH(DIOROOT))_+DIEN
- +6 IF DICLERR'=""!$GET(DIERR)
- Begin DoDot:1
- +7 SET DIERR=$GET(DIERR)+DICLERR_U_($PIECE($GET(DIERR),U,2)+$PIECE(DICLERR,U,2))
- End DoDot:1
- +8 QUIT
- +9 ;
- FILE(DIFILE,DIDA,DIFLAGS,DIROOT) ;
- +1 ; entry point -- given a root, calculate the file # and DA
- +2 ; DO NOT USE UNTIL $QS & $QL AVAILABLE
- +3 NEW DIGLOBAL
- IF $GET(DIFLAGS)'["O"
- SET DIGLOBAL=DIROOT
- +4 IF '$TEST
- SET DIGLOBAL=$$CREF^DIQGU(DIROOT)
- SET DIROOT=DIGLOBAL
- +5 SET DIFILE=+$PIECE($GET(@DIGLOBAL@(0)),U,2)
- SET DIDA=""
- +6 NEW DA,DIENTRY
- SET DA=1
- SET DIENTRY=0
- +7 ;
- LOOP NEW DICHAR,DIL,DILEAD,DIQL,DIQS,DIQSL
- FOR
- Begin DoDot:1
- +1 STRIP +1 ; S DIQL=$QL(DIGLOBAL) Q:'DIQL
- +2 ; S DIQS=$QS(DIGLOBAL,DIQL)
- +3 NEW DIQSL
- SET DIQSL=$LENGTH(DIQS)+1
- IF +DIQS'=DIQS
- SET DIQSL=DIQSL+2
- +4 SET DIL=$LENGTH(DIGLOBAL)
- SET DILEAD=DIL-DIQSL
- +5 SET $EXTRACT(DIGLOBAL,DILEAD+1,DIL-1)=""
- +6 SET DICHAR=$EXTRACT(DIGLOBAL,DILEAD)
- +7 IF DICHAR=","
- SET $EXTRACT(DIGLOBAL,DILEAD)=""
- +8 IF '$TEST
- IF DICHAR="("
- SET $EXTRACT(DIGLOBAL,DILEAD,DILEAD+1)=""
- +9 IF '$TEST
- SET DIGLOBAL="ERROR: "_DIGLOBAL
- SET DIQL=0
- +10 ENTRY IF DIENTRY
- Begin DoDot:2
- +1 SET DIFILE(DA)=+$PIECE($GET(@DIGLOBAL@(0)),U,2)
- +2 SET DIROOT(DA)=DIGLOBAL
- +3 SET DIDA(DA)=DIQS
- SET DA=DA+1
- End DoDot:2
- +4 SET DIENTRY='DIENTRY
- End DoDot:1
- if 'DIQL
- QUIT
- +5 QUIT
- +6 ;
- ERR(DIERN,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3,DIROOT) ;
- +1 ;
- +2 ; error logging procedure
- +3 ; RECALL
- +4 ;
- +5 NEW DIPE,DI
- +6 FOR DI="FILE","IENS","FIELD",1:1:3,"ROOT"
- SET DIPE(DI)=$GET(@("DI"_DI))
- +7 DO BLD^DIALOG(DIERN,.DIPE,.DIPE)
- +8 SET DIERR=$GET(DIERR)+DICLERR_U_($PIECE($GET(DIERR),U,2)+$PIECE(DICLERR,U,2))
- +9 QUIT