DIACLM ;SLCISC/MKB - Policy Editor driver ;17FEB2017
;;22.2;VA FileMan;**8**;Jan 05, 2016;Build 19
;;Per VA Directive 6402, this routine should not be modified.
;
EN ; -- main entry point for DIAC POLICY EDITOR
S DITOP=$$SELECT Q:DITOP<1
K ^TMP("DIACX",$J) S ^($J,+DITOP)=""
D EN^VALM("DIAC POLICY EDITOR")
Q
;
HDR ; -- header code
N I,X,Y,X0,F,DIACT
S Y=0 F S Y=+$O(^DIAC(1.61,"D",+DITOP,Y)) Q:Y<1 D
. S X0=$G(^DIAC(1.61,Y,0)),X=$G(^(1)) S:X="" X=$P(X0,U,3)
. ; DIACT(file#,ien)=description or name
. S DIACT(+$P(X0,U,2),Y)=X
I '$O(DIACT(0)) S VALMHDR(1)="For: <no linked Application Action>" Q
;
S (I,F)=0 F S F=$O(DIACT(F)) Q:F<1 D
. S X="#"_F,Y=0
. F S Y=$O(DIACT(F,Y)) Q:Y<1 S X=X_", "_DIACT(F,Y)
. S I=I+1,VALMHDR(I)=$S(I=1:"For: ",1:" ")_$E(X,1,75)
Q
;
INIT ; -- init variables and list array
N SEQ,STK K ^TMP("DIAC",$J)
S VALMCNT=0,STK=0 D ADD(+DITOP)
S STK=1,STK(STK)=+DITOP_"^0",STK(0)=0
; expand members, if in DIACX list
I $D(^TMP("DIACX",$J,+DITOP)) S SEQ=0 F S SEQ=$O(^DIAC(1.6,+STK(STK),10,"AC",SEQ)) D @$S(SEQ'>0:"POP",1:"PROC") Q:STK<1
S ^TMP("DIAC",$J,0)=VALMCNT_U_+DITOP
S VALMBCK="R",VALMBG=1
Q
;
POP ; -- pop the stack
S STK=STK-1,SEQ=$P(STK(STK),U,2)
Q
PROC ; -- process member
N IEN S $P(STK(STK),U,2)=SEQ
S IEN=+$O(^DIAC(1.6,+STK(STK),10,"AC",SEQ,0)) D ADD(IEN)
; push stack, if expanding policy/set
I $D(^TMP("DIACX",$J,IEN)) S STK=STK+1,STK(STK)=IEN_"^0",SEQ=0
Q
;
ADD(DA) ; -- add row
N PREFIX,X0,NAME,TYPE,EFFECT,LINE
S PREFIX=$S('$O(^DIAC(1.6,DA,10,0)):" ",$D(^TMP("DIACX",$J,DA)):"-",1:"+")
S X0=$G(^DIAC(1.6,DA,0)),NAME=$P(X0,U)
I $P(X0,U,3) S NAME="("_NAME_")" ;disabled
S NAME=PREFIX_NAME S:$G(STK) NAME=$$REPEAT^XLFSTR(" ",STK*2)_NAME
S TYPE=$$EXTERNAL^DILFD(1.6,.02,,$P(X0,U,2))
I $P(X0,U,7) S EFFECT=$P(^DIAC(1.62,+$P(X0,U,7),0),U,2)
E S EFFECT=$$EXTERNAL^DILFD(1.6,.08,,$P(X0,U,8))
S VALMCNT=VALMCNT+1,LINE=$$SETFLD^VALM1(VALMCNT,"","NUMBER")
S LINE=$$SETFLD^VALM1(NAME,LINE,"NAME")
S LINE=$$SETFLD^VALM1(TYPE,LINE,"TYPE")
S LINE=$$SETFLD^VALM1(EFFECT,LINE,"RESULT")
D SET^VALM10(VALMCNT,LINE,VALMCNT)
S ^TMP("DIAC",$J,"IEN",VALMCNT)=DA_U_$P(X0,U)
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("DIAC",$J),^TMP("DIACX",$J),DITOP
Q
;
EXPND ; -- expand code
Q
;
SELECT() ; -- select a policy/set
N X,Y,DIC,DLAYGO
S DIC=1.6,DLAYGO=1.6,DIC(0)="AEQL",DIC("A")="Select POLICY: "
S DIC("?")="Select or create a policy to view and manage."
D FULL^VALM1,^DIC
S VALMBCK="R"
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIACLM 2599 printed Oct 16, 2024@18:45:12 Page 2
DIACLM ;SLCISC/MKB - Policy Editor driver ;17FEB2017
+1 ;;22.2;VA FileMan;**8**;Jan 05, 2016;Build 19
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ; -- main entry point for DIAC POLICY EDITOR
+1 SET DITOP=$$SELECT
if DITOP<1
QUIT
+2 KILL ^TMP("DIACX",$JOB)
SET ^($JOB,+DITOP)=""
+3 DO EN^VALM("DIAC POLICY EDITOR")
+4 QUIT
+5 ;
HDR ; -- header code
+1 NEW I,X,Y,X0,F,DIACT
+2 SET Y=0
FOR
SET Y=+$ORDER(^DIAC(1.61,"D",+DITOP,Y))
if Y<1
QUIT
Begin DoDot:1
+3 SET X0=$GET(^DIAC(1.61,Y,0))
SET X=$GET(^(1))
if X=""
SET X=$PIECE(X0,U,3)
+4 ; DIACT(file#,ien)=description or name
+5 SET DIACT(+$PIECE(X0,U,2),Y)=X
End DoDot:1
+6 IF '$ORDER(DIACT(0))
SET VALMHDR(1)="For: <no linked Application Action>"
QUIT
+7 ;
+8 SET (I,F)=0
FOR
SET F=$ORDER(DIACT(F))
if F<1
QUIT
Begin DoDot:1
+9 SET X="#"_F
SET Y=0
+10 FOR
SET Y=$ORDER(DIACT(F,Y))
if Y<1
QUIT
SET X=X_", "_DIACT(F,Y)
+11 SET I=I+1
SET VALMHDR(I)=$SELECT(I=1:"For: ",1:" ")_$EXTRACT(X,1,75)
End DoDot:1
+12 QUIT
+13 ;
INIT ; -- init variables and list array
+1 NEW SEQ,STK
KILL ^TMP("DIAC",$JOB)
+2 SET VALMCNT=0
SET STK=0
DO ADD(+DITOP)
+3 SET STK=1
SET STK(STK)=+DITOP_"^0"
SET STK(0)=0
+4 ; expand members, if in DIACX list
+5 IF $DATA(^TMP("DIACX",$JOB,+DITOP))
SET SEQ=0
FOR
SET SEQ=$ORDER(^DIAC(1.6,+STK(STK),10,"AC",SEQ))
DO @$SELECT(SEQ'>0:"POP",1:"PROC")
if STK<1
QUIT
+6 SET ^TMP("DIAC",$JOB,0)=VALMCNT_U_+DITOP
+7 SET VALMBCK="R"
SET VALMBG=1
+8 QUIT
+9 ;
POP ; -- pop the stack
+1 SET STK=STK-1
SET SEQ=$PIECE(STK(STK),U,2)
+2 QUIT
PROC ; -- process member
+1 NEW IEN
SET $PIECE(STK(STK),U,2)=SEQ
+2 SET IEN=+$ORDER(^DIAC(1.6,+STK(STK),10,"AC",SEQ,0))
DO ADD(IEN)
+3 ; push stack, if expanding policy/set
+4 IF $DATA(^TMP("DIACX",$JOB,IEN))
SET STK=STK+1
SET STK(STK)=IEN_"^0"
SET SEQ=0
+5 QUIT
+6 ;
ADD(DA) ; -- add row
+1 NEW PREFIX,X0,NAME,TYPE,EFFECT,LINE
+2 SET PREFIX=$SELECT('$ORDER(^DIAC(1.6,DA,10,0)):" ",$DATA(^TMP("DIACX",$JOB,DA)):"-",1:"+")
+3 SET X0=$GET(^DIAC(1.6,DA,0))
SET NAME=$PIECE(X0,U)
+4 ;disabled
IF $PIECE(X0,U,3)
SET NAME="("_NAME_")"
+5 SET NAME=PREFIX_NAME
if $GET(STK)
SET NAME=$$REPEAT^XLFSTR(" ",STK*2)_NAME
+6 SET TYPE=$$EXTERNAL^DILFD(1.6,.02,,$PIECE(X0,U,2))
+7 IF $PIECE(X0,U,7)
SET EFFECT=$PIECE(^DIAC(1.62,+$PIECE(X0,U,7),0),U,2)
+8 IF '$TEST
SET EFFECT=$$EXTERNAL^DILFD(1.6,.08,,$PIECE(X0,U,8))
+9 SET VALMCNT=VALMCNT+1
SET LINE=$$SETFLD^VALM1(VALMCNT,"","NUMBER")
+10 SET LINE=$$SETFLD^VALM1(NAME,LINE,"NAME")
+11 SET LINE=$$SETFLD^VALM1(TYPE,LINE,"TYPE")
+12 SET LINE=$$SETFLD^VALM1(EFFECT,LINE,"RESULT")
+13 DO SET^VALM10(VALMCNT,LINE,VALMCNT)
+14 SET ^TMP("DIAC",$JOB,"IEN",VALMCNT)=DA_U_$PIECE(X0,U)
+15 QUIT
+16 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("DIAC",$JOB),^TMP("DIACX",$JOB),DITOP
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
SELECT() ; -- select a policy/set
+1 NEW X,Y,DIC,DLAYGO
+2 SET DIC=1.6
SET DLAYGO=1.6
SET DIC(0)="AEQL"
SET DIC("A")="Select POLICY: "
+3 SET DIC("?")="Select or create a policy to view and manage."
+4 DO FULL^VALM1
DO ^DIC
+5 SET VALMBCK="R"
+6 QUIT Y
