DICE1 ;SFISC/XAK-TRIGGER LOGIC ;10:24 AM 9 Jul 1999
;;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.
;
FIELD S %=DI,%F=DL,DOLD=$P(^DD(DI,DL,0),U) W !!,"WHEN THE " D WR^DIDH
R "IS CHANGED,",!,"WHAT FIELD SHOULD BE 'TRIGGERED': ",X:DTIME Q:U[X
I X?1."?" S DIC="^DD("_DI_",",DIC(0)="QE",DIC("S")="S %=$P(^(0),U,2) I %'[""C""&(%'[""W"")",DIC("W")="W:$P(^(0),U,2) "" (multiple)""" D ^DIC K DIC G FIELD
F %=0:0 S %=$F(X," IN ") Q:'% S X=$E(X,1,%-5)_":"_$E(X,%,999),%=$F(X," FILE") S:% X=$E(X,1,%-6)_$E(X,%,999)
F %=99:0 S %=$O(I(%)) Q:%="" K I(%),J(%)
S %=-1,DCNEW=X,DICOMP="SW?",X="INTERNAL("_$P(X,":")_")"_$S($F(X,":"):":",1:"")_$P(X,":",2,99) D DA,DICOMP
I '$D(X) S X=DCNEW,DICOMP="SW?" D DICOMP
F %=9.2:.1 Q:'$D(X(%)) S ^UTILITY("DICE",$J,%+80)=X(%)
I '$D(X)!'DICOMPX W !," ...",I,$C(7),!,"YOU MUST IDENTIFY SOME FIELD, EITHER WITHIN THE",!,"'",@("$P("_DIU_"0),U)"),"' FILE OR IN SOME OTHER" G FIELD
S DFLD=X,DENEW=+$P(DICOMPX,U,2),DIN=+DICOMPX,DREF="",DLAY=Y["L"
K X F X=Y\100*100:-100:0 F %=X:1 Q:'$D(J(%)) G CK:J(%)=DIN
W $C(7),!,"SORRY, I AM CONFUSED" G FIELD
CK I DENEW=.001 W $C(7),!,"CAN'T UPDATE A 'NUMBER' FIELD!" G FIELD
I DENEW=DL,DIN=DI W $C(7),!,"CAN'T HAVE A FIELD TRIGGERING ITSELF!!!" G FIELD
S DIFILE=J(X),DIAC="DD" D ^DIAC I '% W $C(7),!,"YOU DON'T HAVE 'DATA DEFINITION' ACCESS TO",!," THE '",$O(^DD(J(X),0,"NM",0)),"' FILE!" G FIELD
I $P($G(^DD(J(X),0,"DI")),U,2)["Y" W $C(7),!,"CAN'T TRIGGER A RESTRICTED"_$S($P(^("DI"),U)["Y":" (ARCHIVE)",1:"")_" FILE!" G FIELD
F X=X:1 S %=X#100,DREF=DREF_I(X)_$E(",",1,%)_"DIV("_%_"),",A=X S:$S('$D(J(%)):1,1:J(%)-J(X))&'$D(DICOMPX(0,J(X))) ^UTILITY("DICE",$J,"DIC")="LOOKUP" Q:J(X)=+DICOMPX!'$D(I(X+1))
S DLOC=$P(^DD(DIN,DENEW,0),U,4),DSUB=$P(DLOC,";"),DLOC=$P(DLOC,";",2),DNEW=$P(^(0),U) S:+DSUB'=DSUB DSUB=""""_DSUB_""""
I $P(^(0),U,2)["C" W !,$C(7),"CAN'T TRIGGER A COMPUTED FIELD!" G FIELD
W " ...OK" K DIFILE,DIAC Q
;
DA S DA="^DD("_DI_","_DL_",1,"_DQ_","_8 Q
;
DICOMP ;
S DICOMPX="",DICOMPX(0)="DIV(",DQI="Y(" G ^DICOMP
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICE1 2302 printed Apr 09, 2024@21:44:46 Page 2
DICE1 ;SFISC/XAK-TRIGGER LOGIC ;10:24 AM 9 Jul 1999
+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 ;
FIELD SET %=DI
SET %F=DL
SET DOLD=$PIECE(^DD(DI,DL,0),U)
WRITE !!,"WHEN THE "
DO WR^DIDH
+1 READ "IS CHANGED,",!,"WHAT FIELD SHOULD BE 'TRIGGERED': ",X:DTIME
if U[X
QUIT
+2 IF X?1."?"
SET DIC="^DD("_DI_","
SET DIC(0)="QE"
SET DIC("S")="S %=$P(^(0),U,2) I %'[""C""&(%'[""W"")"
SET DIC("W")="W:$P(^(0),U,2) "" (multiple)"""
DO ^DIC
KILL DIC
GOTO FIELD
+3 FOR %=0:0
SET %=$FIND(X," IN ")
if '%
QUIT
SET X=$EXTRACT(X,1,%-5)_":"_$EXTRACT(X,%,999)
SET %=$FIND(X," FILE")
if %
SET X=$EXTRACT(X,1,%-6)_$EXTRACT(X,%,999)
+4 FOR %=99:0
SET %=$ORDER(I(%))
if %=""
QUIT
KILL I(%),J(%)
+5 SET %=-1
SET DCNEW=X
SET DICOMP="SW?"
SET X="INTERNAL("_$PIECE(X,":")_")"_$SELECT($FIND(X,":"):":",1:"")_$PIECE(X,":",2,99)
DO DA
DO DICOMP
+6 IF '$DATA(X)
SET X=DCNEW
SET DICOMP="SW?"
DO DICOMP
+7 FOR %=9.2:.1
if '$DATA(X(%))
QUIT
SET ^UTILITY("DICE",$JOB,%+80)=X(%)
+8 IF '$DATA(X)!'DICOMPX
WRITE !," ...",I,$CHAR(7),!,"YOU MUST IDENTIFY SOME FIELD, EITHER WITHIN THE",!,"'",@("$P("_DIU_"0),U)"),"' FILE OR IN SOME OTHER"
GOTO FIELD
+9 SET DFLD=X
SET DENEW=+$PIECE(DICOMPX,U,2)
SET DIN=+DICOMPX
SET DREF=""
SET DLAY=Y["L"
+10 KILL X
FOR X=Y\100*100:-100:0
FOR %=X:1
if '$DATA(J(%))
QUIT
if J(%)=DIN
GOTO CK
+11 WRITE $CHAR(7),!,"SORRY, I AM CONFUSED"
GOTO FIELD
CK IF DENEW=.001
WRITE $CHAR(7),!,"CAN'T UPDATE A 'NUMBER' FIELD!"
GOTO FIELD
+1 IF DENEW=DL
IF DIN=DI
WRITE $CHAR(7),!,"CAN'T HAVE A FIELD TRIGGERING ITSELF!!!"
GOTO FIELD
+2 SET DIFILE=J(X)
SET DIAC="DD"
DO ^DIAC
IF '%
WRITE $CHAR(7),!,"YOU DON'T HAVE 'DATA DEFINITION' ACCESS TO",!," THE '",$ORDER(^DD(J(X),0,"NM",0)),"' FILE!"
GOTO FIELD
+3 IF $PIECE($GET(^DD(J(X),0,"DI")),U,2)["Y"
WRITE $CHAR(7),!,"CAN'T TRIGGER A RESTRICTED"_$SELECT($PIECE(^("DI"),U)["Y":" (ARCHIVE)",1:"")_" FILE!"
GOTO FIELD
+4 FOR X=X:1
SET %=X#100
SET DREF=DREF_I(X)_$EXTRACT(",",1,%)_"DIV("_%_"),"
SET A=X
if $SELECT('$DATA(J(%))
SET ^UTILITY("DICE",$JOB,"DIC")="LOOKUP"
if J(X)=+DICOMPX!'$DATA(I(X+1))
QUIT
+5 SET DLOC=$PIECE(^DD(DIN,DENEW,0),U,4)
SET DSUB=$PIECE(DLOC,";")
SET DLOC=$PIECE(DLOC,";",2)
SET DNEW=$PIECE(^(0),U)
if +DSUB'=DSUB
SET DSUB=""""_DSUB_""""
+6 IF $PIECE(^(0),U,2)["C"
WRITE !,$CHAR(7),"CAN'T TRIGGER A COMPUTED FIELD!"
GOTO FIELD
+7 WRITE " ...OK"
KILL DIFILE,DIAC
QUIT
+8 ;
DA SET DA="^DD("_DI_","_DL_",1,"_DQ_","_8
QUIT
+1 ;
DICOMP ;
+1 SET DICOMPX=""
SET DICOMPX(0)="DIV("
SET DQI="Y("
GOTO ^DICOMP
+2 ;
