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 Oct 16, 2024@18:47:11 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
