Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DIACP

DIACP.m

Go to the documentation of this file. 
  1. DIACP ;SLCISC/MKB - Print Policy Documentation ;17FEB2017
  1.  ;;22.2;VA FileMan;**8**;Jan 05, 2016;Build 19
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1. EN ; -- start here
  1.  N TYPE S TYPE=$$REPORT Q:TYPE="^"
  1.  D @("EN"_TYPE)
  1.  Q
  1.  ;
  1. REPORT() ; -- select report type
  1.  N X,Y,DIR,DUOUT,DTOUT
  1.  S DIR(0)="SAO^1:SUMMARY;2:DETAILED"
  1.  S DIR("A")="Print (S)ummary by Application Action, or (D)etails of a Policy? "
  1.  S DIR("?",1)="Choose Summary to print a list of application actions and their policies,"
  1.  S DIR("?")="or Details to show the full contents of a single policy."
  1.  D ^DIR I Y<1 S Y="^"
  1.  Q Y
  1.  ;
  1. EN1 ; -- print summary list of Events
  1.  N DIC,L,FLDS
  1.  S DIC=1.61,L="LIST ACTIONS",FLDS="[DIAC ACTIONS]"
  1.  D EN1^DIP
  1.  Q
  1.  ;
  1. SELECT() ; -- select a Policy
  1.  N X,Y,DIC
  1.  S DIC=1.6,DIC(0)="AEQM" D ^DIC
  1.  Q $S(Y>0:Y,1:"^")
  1.  ;
  1. EN2 ; -- print Policy details
  1.  N DIPOL S DIPOL=$$SELECT Q:DIPOL<1
  1.  ;
  1.  ;Device
  1.  S %ZIS=$S($D(^%ZTSK):"Q",1:"")
  1.  W ! D ^%ZIS K %ZIS I $G(POP) K POP Q
  1.  K POP
  1.  ;
  1.  ;Queue report?
  1.  I $D(IO("Q")),$D(^%ZTSK) D  G END
  1.  . N ZTRTN,ZTDESC,ZTSAVE
  1.  . S ZTRTN="MAIN^DIACP"
  1.  . S ZTDESC="Report of Policy "_$P(DIPOL,U,2)
  1.  . S ZTSAVE("DIPOL")=""
  1.  . D ^%ZTLOAD
  1.  . I $D(ZTSK)#2 W !,"Report queued!",!,"Task number: "_$G(ZTSK),!
  1.  . E  W !,"Report canceled!",!
  1.  . K ZTSK
  1.  . S IOP="HOME" D ^%ZIS
  1.  ;
  1.  U IO
  1.  ;
  1. MAIN ;entry point for queued report
  1.  N DISTK,DISEQ,DIFCN,DIACHDR,DIACRT,DIACPG
  1.  ;
  1.  D INIT
  1.  D @("HDR"_(2-DIACRT))
  1.  D ACTION
  1.  ;
  1.  ;Unwind members
  1.  S DISTK=0,DISTK(0)=0 D ITEM(+DIPOL) Q:$D(DIRUT)
  1.  S DISTK=1,DISTK(DISTK)=+DIPOL_"^0",DISEQ=0
  1.  F  S DISEQ=$O(^DIAC(1.6,+DISTK(DISTK),10,"AC",DISEQ)) D @$S(+DISEQ'>0:"POP",1:"PROC") Q:DISTK<1  Q:$D(DIRUT)
  1.  ;
  1.  I '$D(DIRUT) D FCNS
  1.  ;
  1. END ;Finish up
  1.  I $D(ZTQUEUED) S ZTREQ="@"
  1.  E  X $G(^%ZIS("C"))
  1.  K DIRUT,DUOUT,DTOUT
  1.  Q
  1.  ;
  1. POP ; pop the stack
  1.  S DISTK=DISTK-1,DISEQ=$P(DISTK(DISTK),U,2)
  1.  Q
  1.  ;
  1. PROC ; process member
  1.  N DIEN
  1.  S $P(DISTK(DISTK),U,2)=DISEQ
  1.  S DIEN=+$O(^DIAC(1.6,+DISTK(DISTK),10,"AC",DISEQ,0)) Q:DIEN<1
  1.  D ITEM(DIEN)
  1.  ; push the stack
  1.  S DISTK=DISTK+1,DISTK(DISTK)=DIEN_"^0",DISEQ=0
  1.  Q
  1.  ;
  1. ITEM(IEN) ; -- top of item
  1.  N X0,X,TYPE,I,DA,T0,NM,VAL
  1.  S X0=$G(^DIAC(1.6,IEN,0)),TYPE=$P(X0,U,2)
  1.  S X=$S($G(DISEQ):DISEQ,TYPE="S":"POLICY SET",TYPE="R":"RULE",1:"POLICY")
  1.  D PG Q:$D(DIRUT)
  1.  W !?((DISTK-1)*3),X_": "_$P(X0,U),?48,"RESULT: "
  1.  I TYPE="R" W $$EFFECT($P(X0,U,8))
  1.  I TYPE'="R",$P(X0,U,7) W $$FNAME($P(X0,U,7)) S DIFCN("R",$P(X0,U,7))=""
  1.  I $P(X0,U,3) D PG Q:$D(DIRUT)  W !?(DISTK*3),"** DISABLED **"
  1.  I $P(X0,U,4) D  Q:$D(DIRUT)
  1.  . D PG Q:$D(DIRUT)
  1.  . W !?(DISTK*3),"ATTRIBUTES: "_$$FNAME($P(X0,U,4))
  1.  . S DIFCN("A",$P(X0,U,4))=""
  1.  ;
  1.  ; targets
  1.  I $O(^DIAC(1.6,IEN,2,0)) D  Q:$D(DIRUT)
  1.  . D PG Q:$D(DIRUT)
  1.  . W !?(DISTK*3),"TARGETS"_$$CONJ($P(X0,U,5))_": "
  1.  . S I=0 F  S I=$O(^DIAC(1.6,IEN,2,"B",I)) Q:I<1  S DA=+$O(^(I,0)) D  Q:$D(DIRUT)
  1.  .. S T0=$G(^DIAC(1.6,IEN,2,DA,0)),NM=$P(T0,U,2),VAL=$P(T0,U,3)
  1.  .. D PG Q:$D(DIRUT)
  1.  .. W !?(DISTK*3),I_":",?((DISTK+1)*3),NM_" = "_VAL
  1.  ;
  1.  ; conditions
  1.  I $O(^DIAC(1.6,IEN,3,0)) D  Q:$D(DIRUT)
  1.  . D PG Q:$D(DIRUT)
  1.  . W !?(DISTK*3),"CONDITIONS"_$$CONJ($P(X0,U,6))_": "
  1.  . S I=0 F  S I=$O(^DIAC(1.6,IEN,3,"B",I)) Q:I<1  S DA=+$O(^(I,0)) D  Q:$D(DIRUT)
  1.  .. S T0=$G(^DIAC(1.6,IEN,3,DA,0)),NM=$P(T0,U,2),VAL=$P(T0,U,3) Q:NM<1
  1.  .. D PG Q:$D(DIRUT)
  1.  .. W !?(DISTK*3),I_":",?((DISTK+1)*3),$$FNAME(NM)_$S($L(VAL):" ("_VAL_")",1:"")
  1.  .. S DIFCN("C",$P(T0,U,2))=""
  1.  ;
  1.  ; messages & functions
  1.  S X=$G(^DIAC(1.6,IEN,7)) ;deny
  1.  I X D PG Q:$D(DIRUT)  W !?(DISTK*3),"DENY FUNCTION: "_$$FNAME(+X) S DIFCN("O",+X)=""
  1.  I $L($P(X,U,2)) D PG Q:$D(DIRUT)  W !?(DISTK*3),"DENY MESSAGE: "_$P(X,U,2)
  1.  S X=$G(^DIAC(1.6,IEN,8)) ;permit
  1.  I X D PG Q:$D(DIRUT)  W !?(DISTK*3),"PERMIT FUNCTION: "_$$FNAME(+X) S DIFCN("O",+X)=""
  1.  I $L($P(X,U,2)) D PG Q:$D(DIRUT)  W !?(DISTK*3),"PERMIT MESSAGE: "_$P(X,U,2)
  1.  ;
  1.  ; available fields
  1.  S X=$G(^DIAC(1.6,IEN,5)) I $L(X) D  Q:$D(DIRUT)
  1.  . D PG Q:$D(DIRUT)
  1.  . W !?(DISTK*3),"FIELDS: "_X
  1.  . S I=0 F  S I=$O(^DIAC(1.6,IEN,5.1,I)) Q:I<1  S X0=$G(^(I,0)) D
  1.  .. S X="("_$P(X0,U)_$S($P(X0,U,3):","_$P(X0,U,3),1:"")_")"
  1.  .. D PG Q:$D(DIRUT)
  1.  .. W !?(DISTK*3),X_": "_$P(X0,U,4)
  1.  ;
  1.  D PG Q:$D(DIRUT)  W !
  1.  ;
  1.  I TYPE'="R",$O(^DIAC(1.6,IEN,10,0)) D  ;caption for next stack level
  1.  . D PG Q:$D(DIRUT)
  1.  . W !?(DISTK*3),$S(TYPE="P":"RULES",1:"POLICIES")_": "
  1.  Q
  1.  ;
  1. CONJ(X) ; -- return name of conjunction
  1.  N Y S Y=$S(X="!":"OR",X="&":"AND",1:"")
  1.  S:$L(Y) Y=" ("_Y_")"
  1.  Q Y
  1.  ;
  1. EFFECT(X) ; -- return Effect name
  1.  N Y S X=$G(X)
  1.  S Y=$S(X="P":"PERMIT",X="D":"DENY",1:"")
  1.  Q Y
  1.  ;
  1. FNAME(X) ; -- return Function name
  1.  Q $P($G(^DIAC(1.62,+$G(X),0)),U)
  1.  ;
  1. FCNS ; -- display functions
  1.  N DITYP,DIEN,X0
  1.  F DITYP="A","C","O","R" D  Q:$D(DIRUT)
  1.  . S DIEN=0 F  S DIEN=$O(DIFCN(DITYP,DIEN)) Q:DIEN<1  D  Q:$D(DIRUT)
  1.  .. S X0=$G(^DIAC(1.62,DIEN,0)) Q:X0=""
  1.  .. D PG Q:$D(DIRUT)  W !,"FUNCTION: "_$P(X0,U)
  1.  .. W ?50,"TYPE: ",$$EXTERNAL^DILFD(1.62,.03,,$P(X0,U,3))
  1.  .. D PG Q:$D(DIRUT)  W !,"  DISPLAY NAME: "_$P(X0,U,2)
  1.  .. I DITYP="R",$L($P(X0,U,4)) D
  1.  ... N X S X=$P(X0,U,4)
  1.  ... W ?44,"NULL VALUE: "_$S(X="P":"PERMIT",X="D":"DENY",1:"")
  1.  .. D PG Q:$D(DIRUT)  W !,"  EXECUTE CODE: "_$G(^DIAC(1.62,DIEN,1))
  1.  .. I $O(^DIAC(1.62,DIEN,2,0)) D DESC(DIEN) Q:$D(DIRUT)
  1.  .. D PG Q:$D(DIRUT)  W !
  1.  Q
  1.  ;
  1. DESC(DA) ; -- write Function Description
  1.  Q:'$O(^DIAC(1.62,+$G(DA),2,0))
  1.  N DII,X
  1.  D PG Q:$D(DIRUT)  W !," DESCRIPTION: "
  1.  S DII=0 F  S DII=$O(^DIAC(1.62,DA,2,DII)) Q:DII<1  S X=$G(^(DII,0)) D PG Q:$D(DIRUT)  W !?1,X
  1.  Q
  1.  ;
  1. INIT ; -- Setup
  1.  N %,%H,X,Y
  1.  S %H=$H D YX^%DTC
  1.  S DIACHDR=$P(Y,"@")_"  "_$P($P(Y,"@",2),":",1,2)_"    PAGE "
  1.  S DIACRT=$E(IOST,1,2)="C-"
  1.  K DIRUT,DUOUT,DTOUT
  1.  Q
  1.  ;
  1. ACTION ; -- display action
  1.  I '$O(^DIAC(1.61,"D",+DIPOL,0)) W !,"APPLICATION ACTION: <none linked>",! Q
  1.  N X0,I,X,DIACT
  1.  S DIACT=0 F  S DIACT=+$O(^DIAC(1.61,"D",+DIPOL,DIACT)) Q:DIACT<1  D
  1.  . S X0=$G(^DIAC(1.61,DIACT,0))
  1.  . W !,"APPLICATION ACTION: ",$P(X0,U),?50,"TYPE: ",$$ACTYP($P(X0,U,4))
  1.  . W !?13,"FILE#: ",$P(X0,U,2),?46,"API NAME: ",$P(X0,U,3)
  1.  . W:$L($G(^DIAC(1.61,DIACT,1))) !," SHORT DESCRIPTION: ",^(1)
  1.  . W:$L($G(^DIAC(1.61,DIACT,5))) !,"  AVAILABLE FIELDS: ",^(5)
  1.  . S I=0 F  S I=$O(^DIAC(1.61,DIACT,5.1,I)) Q:I<1  S X0=$G(^(I,0)) D
  1.  .. S X="("_$P(X0,U)_$S($P(X0,U,3):","_$P(X0,U,3),1:"")_")"
  1.  .. W !,$$RJ^XLFSTR(X,18)_": "_$P(X0,U,4)
  1.  . W !
  1.  Q
  1.  ;
  1. ACTYP(X) ; -- return action type name
  1.  N Y S X=$G(X)
  1.  S Y=$S(X="C":"CREATE",X="R":"READ",X="U":"UPDATE",X="D":"DELETE",1:"")
  1.  Q Y
  1.  ;
  1. PG ; -- check line count for new page
  1.  I $Y+3'<IOSL D HEADER Q:$D(DIRUT)
  1.  Q
  1.  ;
  1.  I DIACRT D  Q:$D(DIRUT)
  1.  . N DIR,X,Y
  1.  . S DIR(0)="E" W ! D ^DIR
  1.  I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DIRUT)=1 Q
  1. HDR1 ;first header for CRTs
  1.  W @IOF
  1. HDR2 ;first header for non-CRTs
  1.  S DIACPG=$G(DIACPG)+1
  1.  ;I $G(DIACT),$L($G(^DIAC(1.61,+$G(DIACT),1))) W ^(1)
  1.  W !,$P(DIPOL,U,2),?(IOM-$L(DIACHDR)-$L(DIACPG)-1),DIACHDR_DIACPG
  1.  W !,$TR($J("",IOM-1)," ","-"),!
  1.  Q