DILF ;SFISC/STAFF-LIBRARY OF FUNCTIONS ;7:08 AM 25 Apr 2006
;;22.0;VA FileMan;**147**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
LOCK(REF) ;
; LOCK the REFerence. $T must be checked upon return **147
I '$D(DILOCKTM) S DILOCKTM=$G(^DD("DILOCKTM"),1) I $D(@REF) ;TO GET NAKED BACK
LOCK @("+"_REF_":DILOCKTM")
Q
;
;
;
CREF(X) G ENCREF^DIQGU
;
OREF(X) G ENOREF^DIQGU
;
FDA(DIEFF,DIEFDAS,DIEFFLD,DIEFFLG,DIEFVAL,DIEFAR,DIEFOUT) ;
G LOADX^DIEF1
;
CLEAN ;
G CLEAN^DIEFU
;
IENS(DIEFDA) ;
G IENX^DIEFU
;
DA(DAIEN,DATARG) ;
G DAX^DIEFU
;
DT(DIEFDT,DIEFX,DIEFY,DIEFDT0,DIOUTAR) ;
G DTX^DIEFU
;
VALUES(DILFILE,DILFLD,DILFDA,DILOUT) ;
I $G(DILFILE)=""!($G(DILFLD)="")!($G(DILFDA)="") S DILOUT=0 Q
K DILOUT
N DILCNT,DILIEN
S DILIEN=""
D VALLOOP
S DILOUT=DILCNT
Q
;
VALLOOP ;
S DILCNT=0
F S DILIEN=$O(@DILFDA@(DILFILE,DILIEN)) Q:DILIEN="" D
. I $D(@DILFDA@(DILFILE,DILIEN,DILFLD)) D
. . S DILCNT=DILCNT+1
. . S DILOUT(DILCNT)=@DILFDA@(DILFILE,DILIEN,DILFLD)
. . S DILOUT(DILCNT,"IENS")=DILIEN
Q
;
VALUE1(DILFILE,DILFLD,DILFDA) ;
I $G(DILFILE)=""!($G(DILFLD)="")!($G(DILFDA)="") Q "^"
N DILIEN
S DILIEN=$O(@DILFDA@(DILFILE,""))
I DILIEN="" Q "^"
I $D(@DILFDA@(DILFILE,DILIEN,DILFLD)) Q @DILFDA@(DILFILE,DILIEN,DILFLD)
N DILCNT,DILOUT
D VALLOOP
I DILCNT Q DILOUT(1)
Q "^"
;
ROUSIZE() ;
Q $G(^DD("ROU"))
;
HTML(DISTRING,DIRECTN) ;
;
; entry point: use HTML to encode or decode ^ and & characters ; TOAD
; extrinsic function: return encoded or decoded value
;
H1 N DILONG,DIRULE I $G(DIRECTN,1)=1 D Q:$G(DILONG) ""
. S DIRULE(1,"&")="&",DIRULE(2,"^")="^"
. N DIL S DIL=$L(DISTRING,"^")+$L(DISTRING,"&")-2
. I $L(DISTRING)-DIL+(DIL*5)>255 D ERR^DICU1(207,,,,DISTRING) S DILONG=1 Q
E S DIRULE(1,"^")="^",DIRULE(2,"&")="&"
Q $$TRANSL8(DISTRING,.DIRULE)
;
TRANSL8(DISTRING,DIRULES) ;
;
; HTML: $TRANSLATE for substrings instead of characters ; TOAD
; extrinsic function: return translated value
;
T1 N DIFRENCE,DIFROM,DILENGTH,DITO
N DI S DI="" F S DI=$O(DIRULES(DI)) Q:DI="" D
. S DIFROM=$O(DIRULES(DI,"")) Q:DISTRING'[DIFROM
. S DITO=DIRULES(DI,DIFROM)
. S DILENGTH=$L(DIFROM)
. S DIFRENCE=$L(DITO)-DILENGTH
. S DIAT=0 F D Q:'DIAT
. . S DIAT=$F(DISTRING,DIFROM,DIAT) Q:'DIAT
. . S $E(DISTRING,DIAT-DILENGTH,DIAT-1)=DITO
. . S DIAT=DIAT+DIFRENCE
Q DISTRING
DILF ;SFISC/STAFF-LIBRARY OF FUNCTIONS ;7:08 AM 25 Apr 2006
+1 ;;22.0;VA FileMan;**147**;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
LOCK(REF) ;
+1 ; LOCK the REFerence. $T must be checked upon return **147
+2 ;TO GET NAKED BACK
IF '$DATA(DILOCKTM)
SET DILOCKTM=$GET(^DD("DILOCKTM"),1)
IF $DATA(@REF)
+3 LOCK @("+"_REF_":DILOCKTM")
+4 QUIT
+5 ;
+6 ;
+7 ;
CREF(X) GOTO ENCREF^DIQGU
+1 ;
OREF(X) GOTO ENOREF^DIQGU
+1 ;
FDA(DIEFF,DIEFDAS,DIEFFLD,DIEFFLG,DIEFVAL,DIEFAR,DIEFOUT) ;
+1 GOTO LOADX^DIEF1
+2 ;
CLEAN ;
+1 GOTO CLEAN^DIEFU
+2 ;
IENS(DIEFDA) ;
+1 GOTO IENX^DIEFU
+2 ;
DA(DAIEN,DATARG) ;
+1 GOTO DAX^DIEFU
+2 ;
DT(DIEFDT,DIEFX,DIEFY,DIEFDT0,DIOUTAR) ;
+1 GOTO DTX^DIEFU
+2 ;
VALUES(DILFILE,DILFLD,DILFDA,DILOUT) ;
+1 IF $GET(DILFILE)=""!($GET(DILFLD)="")!($GET(DILFDA)="")
SET DILOUT=0
QUIT
+2 KILL DILOUT
+3 NEW DILCNT,DILIEN
+4 SET DILIEN=""
+5 DO VALLOOP
+6 SET DILOUT=DILCNT
+7 QUIT
+8 ;
VALLOOP ;
+1 SET DILCNT=0
+2 FOR
SET DILIEN=$ORDER(@DILFDA@(DILFILE,DILIEN))
IF DILIEN=""
QUIT
Begin DoDot:1
+3 IF $DATA(@DILFDA@(DILFILE,DILIEN,DILFLD))
Begin DoDot:2
+4 SET DILCNT=DILCNT+1
+5 SET DILOUT(DILCNT)=@DILFDA@(DILFILE,DILIEN,DILFLD)
+6 SET DILOUT(DILCNT,"IENS")=DILIEN
End DoDot:2
End DoDot:1
+7 QUIT
+8 ;
VALUE1(DILFILE,DILFLD,DILFDA) ;
+1 IF $GET(DILFILE)=""!($GET(DILFLD)="")!($GET(DILFDA)="")
QUIT "^"
+2 NEW DILIEN
+3 SET DILIEN=$ORDER(@DILFDA@(DILFILE,""))
+4 IF DILIEN=""
QUIT "^"
+5 IF $DATA(@DILFDA@(DILFILE,DILIEN,DILFLD))
QUIT @DILFDA@(DILFILE,DILIEN,DILFLD)
+6 NEW DILCNT,DILOUT
+7 DO VALLOOP
+8 IF DILCNT
QUIT DILOUT(1)
+9 QUIT "^"
+10 ;
ROUSIZE() ;
+1 QUIT $GET(^DD("ROU"))
+2 ;
HTML(DISTRING,DIRECTN) ;
+1 ;
+2 ; entry point: use HTML to encode or decode ^ and & characters ; TOAD
+3 ; extrinsic function: return encoded or decoded value
+4 ;
H1 NEW DILONG,DIRULE
IF $GET(DIRECTN,1)=1
Begin DoDot:1
+1 SET DIRULE(1,"&")="&"
SET DIRULE(2,"^")="^"
+2 NEW DIL
SET DIL=$LENGTH(DISTRING,"^")+$LENGTH(DISTRING,"&")-2
+3 IF $LENGTH(DISTRING)-DIL+(DIL*5)>255
DO ERR^DICU1(207,,,,DISTRING)
SET DILONG=1
QUIT
End DoDot:1
IF $GET(DILONG)
QUIT ""
+4 IF '$TEST
SET DIRULE(1,"^")="^"
SET DIRULE(2,"&")="&"
+5 QUIT $$TRANSL8(DISTRING,.DIRULE)
+6 ;
TRANSL8(DISTRING,DIRULES) ;
+1 ;
+2 ; HTML: $TRANSLATE for substrings instead of characters ; TOAD
+3 ; extrinsic function: return translated value
+4 ;
T1 NEW DIFRENCE,DIFROM,DILENGTH,DITO
+1 NEW DI
SET DI=""
FOR
SET DI=$ORDER(DIRULES(DI))
IF DI=""
QUIT
Begin DoDot:1
+2 SET DIFROM=$ORDER(DIRULES(DI,""))
IF DISTRING'[DIFROM
QUIT
+3 SET DITO=DIRULES(DI,DIFROM)
+4 SET DILENGTH=$LENGTH(DIFROM)
+5 SET DIFRENCE=$LENGTH(DITO)-DILENGTH
+6 SET DIAT=0
FOR
Begin DoDot:2
+7 SET DIAT=$FIND(DISTRING,DIFROM,DIAT)
IF 'DIAT
QUIT
+8 SET $EXTRACT(DISTRING,DIAT-DILENGTH,DIAT-1)=DITO
+9 SET DIAT=DIAT+DIFRENCE
End DoDot:2
IF 'DIAT
QUIT
End DoDot:1
+10 QUIT DISTRING
