- 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 Feb 19, 2025@00:10:54 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
