- DICE4 ;SFISC/GFT-TRIGGER LOGIC ;26NOV2004
- ;;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.
- ;
- D SET S DTAG="S DIH=$G("_DREF_DSUB_")),DIV=X "_$P("I $D(^(0)) ","""",A>99)_X_",DIH="_DIN_",DIG="_DENEW_" D ^DICR",X=""
- S:$L(DE)+$L(DTAG)>160&($L(DE)>30) ^UTILITY("DICE",$J,DIK+.1)=DE,DE="X "_DA_DIK_".1)" S X=DE
- F ;
- S DB=DA_DIK
- S:$L(Y)+$L(X)>190 ^UTILITY("DICE",$J,DIK+.2)=Y,Y="X "_DB_".2)" S:$L(Y) X=Y_" "_X
- K DICOMPX(DNEW) S DHI=X,DCOND=DCOND_"TING OF '"_DNEW_"'" D COND G P:'$D(DCOND) I DLAY,DICOMPX,DICOMPX-DI W !,"SORRY, CAN'T DO THIS WHEN 'LAYGO' ALLOWED" S X=U Q
- S DHI="I X S X=DIV "_DHI I $O(J(A))>0 S ^("DIC")=""
- P S:$L(DHI)+$L(X)>220 ^UTILITY("DICE",$J,DIK+.3)=X,X="X "_DB_".3)" S X=X_" "_DHI
- S:$L(DTAG)+$L(X)>225 ^UTILITY("DICE",$J,DIK+.4)=DTAG,DTAG="X "_DB_".4)" S ^UTILITY("DICE",$J,DIK)=X_" "_DTAG K DTAG,D Q
- ;
- SET G PIECE:DLOC S DHI=$P(DLOC,",",2),%=+$E(DLOC,2,9),X="S DE="_(%-1)_"-$L(DIH),DIU=$E(DIH,"_%_","_DHI_"),Y=$E(DIH,"_(DHI+1)_",999),^("_DSUB_")="
- I %>1 S X=X_"$E(DIH,1,"_(%-1)_")_"
- S X=X_"$J("""",$S(DE>0:DE,1:0))_DIV_$S(Y?."" "":"""",1:$J("""","_(DHI-%+1)_"-$L(DIV))_Y)" Q
- PIECE S X="S $P(^("_DSUB_"),U,"_DLOC_")=DIV" Q
- ;
- COND S DE=" DIV=X" F %=0:1:N S DE=DE_",D"_%_"=DA"_$S(%=N:"",1:"("_(N-%)_")") I A#100'<% S DE=DE_",DIV("_%_")=D"_%
- D CC I $D(DCOND) S DE=DE_" "_X
- S X="K DIV S"_DE
- Q Q
- ;
- CC ;
- S DA=DA_(DIK+5)
- R W !!,"DO YOU WANT TO MAKE THE "_DCOND_" CONDITIONAL" K DICOMPX S %=2,DICOMPX="",DICOMP="?",D="ENTER AN EXPRESSION FOR THE CONDITION: " D YN^DICN I %-1 K DCOND Q
- I DIK=1 S DICOMPX("Y(0)")="Y(0)",DICOMPX(1,DI,DL)="Y(0)",DICOMPX("Y(0)",U)=DI_U_DL
- E W ! D OLD^DICE2 S Y="CREATE CONDITION" I $D(^UTILITY("DICE",$J,Y)) W !,D_^(Y)_"// " R X:DTIME S:'$T DTOUT=1 G Q:X=U!'$T S:X="" X=^(Y) G X
- W !,D R X:DTIME S:'$T DTOUT=1 G Q:X=U!'$T
- X I X?."?" W !,"ENTER A TRUTH-VALUED 'COMPUTED-FIELD' EXPRESSION ",!?4,"(PERHAPS INVOLVING '"_DOLD_"')" G R
- S DCOND(0)=X D ^DICOMP I $D(X) W:Y'["B" !,"WARNING--THIS DOESN'T LOOK LIKE A CONDITION EXPRESSION!" S X="S Y(0)=X "_X,^UTILITY("DICE",$J,$P("CREA^DELE",U,DIK)_"TE CONDITION")=DCOND(0) F %=9.2:.1 G Q:'$D(X(%)) S ^(DIK+5*10+%)=X(%) K X(%)
- W $C(7),"??" G R
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICE4 2428 printed Feb 19, 2025@00:12:12 Page 2
- DICE4 ;SFISC/GFT-TRIGGER LOGIC ;26NOV2004
- +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 DO SET
- SET DTAG="S DIH=$G("_DREF_DSUB_")),DIV=X "_$PIECE("I $D(^(0)) ","""",A>99)_X_",DIH="_DIN_",DIG="_DENEW_" D ^DICR"
- SET X=""
- +8 if $LENGTH(DE)+$LENGTH(DTAG)>160&($LENGTH(DE)>30)
- SET ^UTILITY("DICE",$JOB,DIK+.1)=DE
- SET DE="X "_DA_DIK_".1)"
- SET X=DE
- F ;
- +1 SET DB=DA_DIK
- +2 if $LENGTH(Y)+$LENGTH(X)>190
- SET ^UTILITY("DICE",$JOB,DIK+.2)=Y
- SET Y="X "_DB_".2)"
- if $LENGTH(Y)
- SET X=Y_" "_X
- +3 KILL DICOMPX(DNEW)
- SET DHI=X
- SET DCOND=DCOND_"TING OF '"_DNEW_"'"
- DO COND
- if '$DATA(DCOND)
- GOTO P
- IF DLAY
- IF DICOMPX
- IF DICOMPX-DI
- WRITE !,"SORRY, CAN'T DO THIS WHEN 'LAYGO' ALLOWED"
- SET X=U
- QUIT
- +4 SET DHI="I X S X=DIV "_DHI
- IF $ORDER(J(A))>0
- SET ^("DIC")=""
- P if $LENGTH(DHI)+$LENGTH(X)>220
- SET ^UTILITY("DICE",$JOB,DIK+.3)=X
- SET X="X "_DB_".3)"
- SET X=X_" "_DHI
- +1 if $LENGTH(DTAG)+$LENGTH(X)>225
- SET ^UTILITY("DICE",$JOB,DIK+.4)=DTAG
- SET DTAG="X "_DB_".4)"
- SET ^UTILITY("DICE",$JOB,DIK)=X_" "_DTAG
- KILL DTAG,D
- QUIT
- +2 ;
- SET if DLOC
- GOTO PIECE
- SET DHI=$PIECE(DLOC,",",2)
- SET %=+$EXTRACT(DLOC,2,9)
- SET X="S DE="_(%-1)_"-$L(DIH),DIU=$E(DIH,"_%_","_DHI_"),Y=$E(DIH,"_(DHI+1)_",999),^("_DSUB_")="
- +1 IF %>1
- SET X=X_"$E(DIH,1,"_(%-1)_")_"
- +2 SET X=X_"$J("""",$S(DE>0:DE,1:0))_DIV_$S(Y?."" "":"""",1:$J("""","_(DHI-%+1)_"-$L(DIV))_Y)"
- QUIT
- PIECE SET X="S $P(^("_DSUB_"),U,"_DLOC_")=DIV"
- QUIT
- +1 ;
- COND SET DE=" DIV=X"
- FOR %=0:1:N
- SET DE=DE_",D"_%_"=DA"_$SELECT(%=N:"",1:"("_(N-%)_")")
- IF A#100'<%
- SET DE=DE_",DIV("_%_")=D"_%
- +1 DO CC
- IF $DATA(DCOND)
- SET DE=DE_" "_X
- +2 SET X="K DIV S"_DE
- Q QUIT
- +1 ;
- CC ;
- +1 SET DA=DA_(DIK+5)
- R WRITE !!,"DO YOU WANT TO MAKE THE "_DCOND_" CONDITIONAL"
- KILL DICOMPX
- SET %=2
- SET DICOMPX=""
- SET DICOMP="?"
- SET D="ENTER AN EXPRESSION FOR THE CONDITION: "
- DO YN^DICN
- IF %-1
- KILL DCOND
- QUIT
- +1 IF DIK=1
- SET DICOMPX("Y(0)")="Y(0)"
- SET DICOMPX(1,DI,DL)="Y(0)"
- SET DICOMPX("Y(0)",U)=DI_U_DL
- +2 IF '$TEST
- WRITE !
- DO OLD^DICE2
- SET Y="CREATE CONDITION"
- IF $DATA(^UTILITY("DICE",$JOB,Y))
- WRITE !,D_^(Y)_"// "
- READ X:DTIME
- if '$TEST
- SET DTOUT=1
- if X=U!'$TEST
- GOTO Q
- if X=""
- SET X=^(Y)
- GOTO X
- +3 WRITE !,D
- READ X:DTIME
- if '$TEST
- SET DTOUT=1
- if X=U!'$TEST
- GOTO Q
- X IF X?."?"
- WRITE !,"ENTER A TRUTH-VALUED 'COMPUTED-FIELD' EXPRESSION ",!?4,"(PERHAPS INVOLVING '"_DOLD_"')"
- GOTO R
- +1 SET DCOND(0)=X
- DO ^DICOMP
- IF $DATA(X)
- if Y'["B"
- WRITE !,"WARNING--THIS DOESN'T LOOK LIKE A CONDITION EXPRESSION!"
- SET X="S Y(0)=X "_X
- SET ^UTILITY("DICE",$JOB,$PIECE("CREA^DELE",U,DIK)_"TE CONDITION")=DCOND(0)
- FOR %=9.2:.1
- if '$DATA(X(%))
- GOTO Q
- SET ^(DIK+5*10+%)=X(%)
- KILL X(%)
- +2 WRITE $CHAR(7),"??"
- GOTO R
