DIACP ;SLCISC/MKB - Print Policy Documentation ;17FEB2017
;;22.2;VA FileMan;**8**;Jan 05, 2016;Build 19
;;Per VA Directive 6402, this routine should not be modified.
;
EN ; -- start here
N TYPE S TYPE=$$REPORT Q:TYPE="^"
D @("EN"_TYPE)
Q
;
REPORT() ; -- select report type
N X,Y,DIR,DUOUT,DTOUT
S DIR(0)="SAO^1:SUMMARY;2:DETAILED"
S DIR("A")="Print (S)ummary by Application Action, or (D)etails of a Policy? "
S DIR("?",1)="Choose Summary to print a list of application actions and their policies,"
S DIR("?")="or Details to show the full contents of a single policy."
D ^DIR I Y<1 S Y="^"
Q Y
;
EN1 ; -- print summary list of Events
N DIC,L,FLDS
S DIC=1.61,L="LIST ACTIONS",FLDS="[DIAC ACTIONS]"
D EN1^DIP
Q
;
SELECT() ; -- select a Policy
N X,Y,DIC
S DIC=1.6,DIC(0)="AEQM" D ^DIC
Q $S(Y>0:Y,1:"^")
;
EN2 ; -- print Policy details
N DIPOL S DIPOL=$$SELECT Q:DIPOL<1
;
;Device
S %ZIS=$S($D(^%ZTSK):"Q",1:"")
W ! D ^%ZIS K %ZIS I $G(POP) K POP Q
K POP
;
;Queue report?
I $D(IO("Q")),$D(^%ZTSK) D G END
. N ZTRTN,ZTDESC,ZTSAVE
. S ZTRTN="MAIN^DIACP"
. S ZTDESC="Report of Policy "_$P(DIPOL,U,2)
. S ZTSAVE("DIPOL")=""
. D ^%ZTLOAD
. I $D(ZTSK)#2 W !,"Report queued!",!,"Task number: "_$G(ZTSK),!
. E W !,"Report canceled!",!
. K ZTSK
. S IOP="HOME" D ^%ZIS
;
U IO
;
MAIN ;entry point for queued report
N DISTK,DISEQ,DIFCN,DIACHDR,DIACRT,DIACPG
;
D INIT
D @("HDR"_(2-DIACRT))
D ACTION
;
;Unwind members
S DISTK=0,DISTK(0)=0 D ITEM(+DIPOL) Q:$D(DIRUT)
S DISTK=1,DISTK(DISTK)=+DIPOL_"^0",DISEQ=0
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)
;
I '$D(DIRUT) D FCNS
;
END ;Finish up
I $D(ZTQUEUED) S ZTREQ="@"
E X $G(^%ZIS("C"))
K DIRUT,DUOUT,DTOUT
Q
;
POP ; pop the stack
S DISTK=DISTK-1,DISEQ=$P(DISTK(DISTK),U,2)
Q
;
PROC ; process member
N DIEN
S $P(DISTK(DISTK),U,2)=DISEQ
S DIEN=+$O(^DIAC(1.6,+DISTK(DISTK),10,"AC",DISEQ,0)) Q:DIEN<1
D ITEM(DIEN)
; push the stack
S DISTK=DISTK+1,DISTK(DISTK)=DIEN_"^0",DISEQ=0
Q
;
ITEM(IEN) ; -- top of item
N X0,X,TYPE,I,DA,T0,NM,VAL
S X0=$G(^DIAC(1.6,IEN,0)),TYPE=$P(X0,U,2)
S X=$S($G(DISEQ):DISEQ,TYPE="S":"POLICY SET",TYPE="R":"RULE",1:"POLICY")
D PG Q:$D(DIRUT)
W !?((DISTK-1)*3),X_": "_$P(X0,U),?48,"RESULT: "
I TYPE="R" W $$EFFECT($P(X0,U,8))
I TYPE'="R",$P(X0,U,7) W $$FNAME($P(X0,U,7)) S DIFCN("R",$P(X0,U,7))=""
I $P(X0,U,3) D PG Q:$D(DIRUT) W !?(DISTK*3),"** DISABLED **"
I $P(X0,U,4) D Q:$D(DIRUT)
. D PG Q:$D(DIRUT)
. W !?(DISTK*3),"ATTRIBUTES: "_$$FNAME($P(X0,U,4))
. S DIFCN("A",$P(X0,U,4))=""
;
; targets
I $O(^DIAC(1.6,IEN,2,0)) D Q:$D(DIRUT)
. D PG Q:$D(DIRUT)
. W !?(DISTK*3),"TARGETS"_$$CONJ($P(X0,U,5))_": "
. 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)
.. S T0=$G(^DIAC(1.6,IEN,2,DA,0)),NM=$P(T0,U,2),VAL=$P(T0,U,3)
.. D PG Q:$D(DIRUT)
.. W !?(DISTK*3),I_":",?((DISTK+1)*3),NM_" = "_VAL
;
; conditions
I $O(^DIAC(1.6,IEN,3,0)) D Q:$D(DIRUT)
. D PG Q:$D(DIRUT)
. W !?(DISTK*3),"CONDITIONS"_$$CONJ($P(X0,U,6))_": "
. 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)
.. S T0=$G(^DIAC(1.6,IEN,3,DA,0)),NM=$P(T0,U,2),VAL=$P(T0,U,3) Q:NM<1
.. D PG Q:$D(DIRUT)
.. W !?(DISTK*3),I_":",?((DISTK+1)*3),$$FNAME(NM)_$S($L(VAL):" ("_VAL_")",1:"")
.. S DIFCN("C",$P(T0,U,2))=""
;
; messages & functions
S X=$G(^DIAC(1.6,IEN,7)) ;deny
I X D PG Q:$D(DIRUT) W !?(DISTK*3),"DENY FUNCTION: "_$$FNAME(+X) S DIFCN("O",+X)=""
I $L($P(X,U,2)) D PG Q:$D(DIRUT) W !?(DISTK*3),"DENY MESSAGE: "_$P(X,U,2)
S X=$G(^DIAC(1.6,IEN,8)) ;permit
I X D PG Q:$D(DIRUT) W !?(DISTK*3),"PERMIT FUNCTION: "_$$FNAME(+X) S DIFCN("O",+X)=""
I $L($P(X,U,2)) D PG Q:$D(DIRUT) W !?(DISTK*3),"PERMIT MESSAGE: "_$P(X,U,2)
;
; available fields
S X=$G(^DIAC(1.6,IEN,5)) I $L(X) D Q:$D(DIRUT)
. D PG Q:$D(DIRUT)
. W !?(DISTK*3),"FIELDS: "_X
. S I=0 F S I=$O(^DIAC(1.6,IEN,5.1,I)) Q:I<1 S X0=$G(^(I,0)) D
.. S X="("_$P(X0,U)_$S($P(X0,U,3):","_$P(X0,U,3),1:"")_")"
.. D PG Q:$D(DIRUT)
.. W !?(DISTK*3),X_": "_$P(X0,U,4)
;
D PG Q:$D(DIRUT) W !
;
I TYPE'="R",$O(^DIAC(1.6,IEN,10,0)) D ;caption for next stack level
. D PG Q:$D(DIRUT)
. W !?(DISTK*3),$S(TYPE="P":"RULES",1:"POLICIES")_": "
Q
;
CONJ(X) ; -- return name of conjunction
N Y S Y=$S(X="!":"OR",X="&":"AND",1:"")
S:$L(Y) Y=" ("_Y_")"
Q Y
;
EFFECT(X) ; -- return Effect name
N Y S X=$G(X)
S Y=$S(X="P":"PERMIT",X="D":"DENY",1:"")
Q Y
;
FNAME(X) ; -- return Function name
Q $P($G(^DIAC(1.62,+$G(X),0)),U)
;
FCNS ; -- display functions
N DITYP,DIEN,X0
F DITYP="A","C","O","R" D Q:$D(DIRUT)
. S DIEN=0 F S DIEN=$O(DIFCN(DITYP,DIEN)) Q:DIEN<1 D Q:$D(DIRUT)
.. S X0=$G(^DIAC(1.62,DIEN,0)) Q:X0=""
.. D PG Q:$D(DIRUT) W !,"FUNCTION: "_$P(X0,U)
.. W ?50,"TYPE: ",$$EXTERNAL^DILFD(1.62,.03,,$P(X0,U,3))
.. D PG Q:$D(DIRUT) W !," DISPLAY NAME: "_$P(X0,U,2)
.. I DITYP="R",$L($P(X0,U,4)) D
... N X S X=$P(X0,U,4)
... W ?44,"NULL VALUE: "_$S(X="P":"PERMIT",X="D":"DENY",1:"")
.. D PG Q:$D(DIRUT) W !," EXECUTE CODE: "_$G(^DIAC(1.62,DIEN,1))
.. I $O(^DIAC(1.62,DIEN,2,0)) D DESC(DIEN) Q:$D(DIRUT)
.. D PG Q:$D(DIRUT) W !
Q
;
DESC(DA) ; -- write Function Description
Q:'$O(^DIAC(1.62,+$G(DA),2,0))
N DII,X
D PG Q:$D(DIRUT) W !," DESCRIPTION: "
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
Q
;
INIT ; -- Setup
N %,%H,X,Y
S %H=$H D YX^%DTC
S DIACHDR=$P(Y,"@")_" "_$P($P(Y,"@",2),":",1,2)_" PAGE "
S DIACRT=$E(IOST,1,2)="C-"
K DIRUT,DUOUT,DTOUT
Q
;
ACTION ; -- display action
I '$O(^DIAC(1.61,"D",+DIPOL,0)) W !,"APPLICATION ACTION: <none linked>",! Q
N X0,I,X,DIACT
S DIACT=0 F S DIACT=+$O(^DIAC(1.61,"D",+DIPOL,DIACT)) Q:DIACT<1 D
. S X0=$G(^DIAC(1.61,DIACT,0))
. W !,"APPLICATION ACTION: ",$P(X0,U),?50,"TYPE: ",$$ACTYP($P(X0,U,4))
. W !?13,"FILE#: ",$P(X0,U,2),?46,"API NAME: ",$P(X0,U,3)
. W:$L($G(^DIAC(1.61,DIACT,1))) !," SHORT DESCRIPTION: ",^(1)
. W:$L($G(^DIAC(1.61,DIACT,5))) !," AVAILABLE FIELDS: ",^(5)
. S I=0 F S I=$O(^DIAC(1.61,DIACT,5.1,I)) Q:I<1 S X0=$G(^(I,0)) D
.. S X="("_$P(X0,U)_$S($P(X0,U,3):","_$P(X0,U,3),1:"")_")"
.. W !,$$RJ^XLFSTR(X,18)_": "_$P(X0,U,4)
. W !
Q
;
ACTYP(X) ; -- return action type name
N Y S X=$G(X)
S Y=$S(X="C":"CREATE",X="R":"READ",X="U":"UPDATE",X="D":"DELETE",1:"")
Q Y
;
PG ; -- check line count for new page
I $Y+3'<IOSL D HEADER Q:$D(DIRUT)
Q
;
I DIACRT D Q:$D(DIRUT)
. N DIR,X,Y
. S DIR(0)="E" W ! D ^DIR
I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DIRUT)=1 Q
HDR1 ;first header for CRTs
W @IOF
HDR2 ;first header for non-CRTs
S DIACPG=$G(DIACPG)+1
;I $G(DIACT),$L($G(^DIAC(1.61,+$G(DIACT),1))) W ^(1)
W !,$P(DIPOL,U,2),?(IOM-$L(DIACHDR)-$L(DIACPG)-1),DIACHDR_DIACPG
W !,$TR($J("",IOM-1)," ","-"),!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIACP 7061 printed Apr 09, 2024@21:45:05 Page 2
DIACP ;SLCISC/MKB - Print Policy Documentation ;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 ; -- start here
+1 NEW TYPE
SET TYPE=$$REPORT
if TYPE="^"
QUIT
+2 DO @("EN"_TYPE)
+3 QUIT
+4 ;
REPORT() ; -- select report type
+1 NEW X,Y,DIR,DUOUT,DTOUT
+2 SET DIR(0)="SAO^1:SUMMARY;2:DETAILED"
+3 SET DIR("A")="Print (S)ummary by Application Action, or (D)etails of a Policy? "
+4 SET DIR("?",1)="Choose Summary to print a list of application actions and their policies,"
+5 SET DIR("?")="or Details to show the full contents of a single policy."
+6 DO ^DIR
IF Y<1
SET Y="^"
+7 QUIT Y
+8 ;
EN1 ; -- print summary list of Events
+1 NEW DIC,L,FLDS
+2 SET DIC=1.61
SET L="LIST ACTIONS"
SET FLDS="[DIAC ACTIONS]"
+3 DO EN1^DIP
+4 QUIT
+5 ;
SELECT() ; -- select a Policy
+1 NEW X,Y,DIC
+2 SET DIC=1.6
SET DIC(0)="AEQM"
DO ^DIC
+3 QUIT $SELECT(Y>0:Y,1:"^")
+4 ;
EN2 ; -- print Policy details
+1 NEW DIPOL
SET DIPOL=$$SELECT
if DIPOL<1
QUIT
+2 ;
+3 ;Device
+4 SET %ZIS=$SELECT($DATA(^%ZTSK):"Q",1:"")
+5 WRITE !
DO ^%ZIS
KILL %ZIS
IF $GET(POP)
KILL POP
QUIT
+6 KILL POP
+7 ;
+8 ;Queue report?
+9 IF $DATA(IO("Q"))
IF $DATA(^%ZTSK)
Begin DoDot:1
+10 NEW ZTRTN,ZTDESC,ZTSAVE
+11 SET ZTRTN="MAIN^DIACP"
+12 SET ZTDESC="Report of Policy "_$PIECE(DIPOL,U,2)
+13 SET ZTSAVE("DIPOL")=""
+14 DO ^%ZTLOAD
+15 IF $DATA(ZTSK)#2
WRITE !,"Report queued!",!,"Task number: "_$GET(ZTSK),!
+16 IF '$TEST
WRITE !,"Report canceled!",!
+17 KILL ZTSK
+18 SET IOP="HOME"
DO ^%ZIS
End DoDot:1
GOTO END
+19 ;
+20 USE IO
+21 ;
MAIN ;entry point for queued report
+1 NEW DISTK,DISEQ,DIFCN,DIACHDR,DIACRT,DIACPG
+2 ;
+3 DO INIT
+4 DO @("HDR"_(2-DIACRT))
+5 DO ACTION
+6 ;
+7 ;Unwind members
+8 SET DISTK=0
SET DISTK(0)=0
DO ITEM(+DIPOL)
if $DATA(DIRUT)
QUIT
+9 SET DISTK=1
SET DISTK(DISTK)=+DIPOL_"^0"
SET DISEQ=0
+10 FOR
SET DISEQ=$ORDER(^DIAC(1.6,+DISTK(DISTK),10,"AC",DISEQ))
DO @$SELECT(+DISEQ'>0:"POP",1:"PROC")
if DISTK<1
QUIT
if $DATA(DIRUT)
QUIT
+11 ;
+12 IF '$DATA(DIRUT)
DO FCNS
+13 ;
END ;Finish up
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 IF '$TEST
XECUTE $GET(^%ZIS("C"))
+3 KILL DIRUT,DUOUT,DTOUT
+4 QUIT
+5 ;
POP ; pop the stack
+1 SET DISTK=DISTK-1
SET DISEQ=$PIECE(DISTK(DISTK),U,2)
+2 QUIT
+3 ;
PROC ; process member
+1 NEW DIEN
+2 SET $PIECE(DISTK(DISTK),U,2)=DISEQ
+3 SET DIEN=+$ORDER(^DIAC(1.6,+DISTK(DISTK),10,"AC",DISEQ,0))
if DIEN<1
QUIT
+4 DO ITEM(DIEN)
+5 ; push the stack
+6 SET DISTK=DISTK+1
SET DISTK(DISTK)=DIEN_"^0"
SET DISEQ=0
+7 QUIT
+8 ;
ITEM(IEN) ; -- top of item
+1 NEW X0,X,TYPE,I,DA,T0,NM,VAL
+2 SET X0=$GET(^DIAC(1.6,IEN,0))
SET TYPE=$PIECE(X0,U,2)
+3 SET X=$SELECT($GET(DISEQ):DISEQ,TYPE="S":"POLICY SET",TYPE="R":"RULE",1:"POLICY")
+4 DO PG
if $DATA(DIRUT)
QUIT
+5 WRITE !?((DISTK-1)*3),X_": "_$PIECE(X0,U),?48,"RESULT: "
+6 IF TYPE="R"
WRITE $$EFFECT($PIECE(X0,U,8))
+7 IF TYPE'="R"
IF $PIECE(X0,U,7)
WRITE $$FNAME($PIECE(X0,U,7))
SET DIFCN("R",$PIECE(X0,U,7))=""
+8 IF $PIECE(X0,U,3)
DO PG
if $DATA(DIRUT)
QUIT
WRITE !?(DISTK*3),"** DISABLED **"
+9 IF $PIECE(X0,U,4)
Begin DoDot:1
+10 DO PG
if $DATA(DIRUT)
QUIT
+11 WRITE !?(DISTK*3),"ATTRIBUTES: "_$$FNAME($PIECE(X0,U,4))
+12 SET DIFCN("A",$PIECE(X0,U,4))=""
End DoDot:1
if $DATA(DIRUT)
QUIT
+13 ;
+14 ; targets
+15 IF $ORDER(^DIAC(1.6,IEN,2,0))
Begin DoDot:1
+16 DO PG
if $DATA(DIRUT)
QUIT
+17 WRITE !?(DISTK*3),"TARGETS"_$$CONJ($PIECE(X0,U,5))_": "
+18 SET I=0
FOR
SET I=$ORDER(^DIAC(1.6,IEN,2,"B",I))
if I<1
QUIT
SET DA=+$ORDER(^(I,0))
Begin DoDot:2
+19 SET T0=$GET(^DIAC(1.6,IEN,2,DA,0))
SET NM=$PIECE(T0,U,2)
SET VAL=$PIECE(T0,U,3)
+20 DO PG
if $DATA(DIRUT)
QUIT
+21 WRITE !?(DISTK*3),I_":",?((DISTK+1)*3),NM_" = "_VAL
End DoDot:2
if $DATA(DIRUT)
QUIT
End DoDot:1
if $DATA(DIRUT)
QUIT
+22 ;
+23 ; conditions
+24 IF $ORDER(^DIAC(1.6,IEN,3,0))
Begin DoDot:1
+25 DO PG
if $DATA(DIRUT)
QUIT
+26 WRITE !?(DISTK*3),"CONDITIONS"_$$CONJ($PIECE(X0,U,6))_": "
+27 SET I=0
FOR
SET I=$ORDER(^DIAC(1.6,IEN,3,"B",I))
if I<1
QUIT
SET DA=+$ORDER(^(I,0))
Begin DoDot:2
+28 SET T0=$GET(^DIAC(1.6,IEN,3,DA,0))
SET NM=$PIECE(T0,U,2)
SET VAL=$PIECE(T0,U,3)
if NM<1
QUIT
+29 DO PG
if $DATA(DIRUT)
QUIT
+30 WRITE !?(DISTK*3),I_":",?((DISTK+1)*3),$$FNAME(NM)_$SELECT($LENGTH(VAL):" ("_VAL_")",1:"")
+31 SET DIFCN("C",$PIECE(T0,U,2))=""
End DoDot:2
if $DATA(DIRUT)
QUIT
End DoDot:1
if $DATA(DIRUT)
QUIT
+32 ;
+33 ; messages & functions
+34 ;deny
SET X=$GET(^DIAC(1.6,IEN,7))
+35 IF X
DO PG
if $DATA(DIRUT)
QUIT
WRITE !?(DISTK*3),"DENY FUNCTION: "_$$FNAME(+X)
SET DIFCN("O",+X)=""
+36 IF $LENGTH($PIECE(X,U,2))
DO PG
if $DATA(DIRUT)
QUIT
WRITE !?(DISTK*3),"DENY MESSAGE: "_$PIECE(X,U,2)
+37 ;permit
SET X=$GET(^DIAC(1.6,IEN,8))
+38 IF X
DO PG
if $DATA(DIRUT)
QUIT
WRITE !?(DISTK*3),"PERMIT FUNCTION: "_$$FNAME(+X)
SET DIFCN("O",+X)=""
+39 IF $LENGTH($PIECE(X,U,2))
DO PG
if $DATA(DIRUT)
QUIT
WRITE !?(DISTK*3),"PERMIT MESSAGE: "_$PIECE(X,U,2)
+40 ;
+41 ; available fields
+42 SET X=$GET(^DIAC(1.6,IEN,5))
IF $LENGTH(X)
Begin DoDot:1
+43 DO PG
if $DATA(DIRUT)
QUIT
+44 WRITE !?(DISTK*3),"FIELDS: "_X
+45 SET I=0
FOR
SET I=$ORDER(^DIAC(1.6,IEN,5.1,I))
if I<1
QUIT
SET X0=$GET(^(I,0))
Begin DoDot:2
+46 SET X="("_$PIECE(X0,U)_$SELECT($PIECE(X0,U,3):","_$PIECE(X0,U,3),1:"")_")"
+47 DO PG
if $DATA(DIRUT)
QUIT
+48 WRITE !?(DISTK*3),X_": "_$PIECE(X0,U,4)
End DoDot:2
End DoDot:1
if $DATA(DIRUT)
QUIT
+49 ;
+50 DO PG
if $DATA(DIRUT)
QUIT
WRITE !
+51 ;
+52 ;caption for next stack level
IF TYPE'="R"
IF $ORDER(^DIAC(1.6,IEN,10,0))
Begin DoDot:1
+53 DO PG
if $DATA(DIRUT)
QUIT
+54 WRITE !?(DISTK*3),$SELECT(TYPE="P":"RULES",1:"POLICIES")_": "
End DoDot:1
+55 QUIT
+56 ;
CONJ(X) ; -- return name of conjunction
+1 NEW Y
SET Y=$SELECT(X="!":"OR",X="&":"AND",1:"")
+2 if $LENGTH(Y)
SET Y=" ("_Y_")"
+3 QUIT Y
+4 ;
EFFECT(X) ; -- return Effect name
+1 NEW Y
SET X=$GET(X)
+2 SET Y=$SELECT(X="P":"PERMIT",X="D":"DENY",1:"")
+3 QUIT Y
+4 ;
FNAME(X) ; -- return Function name
+1 QUIT $PIECE($GET(^DIAC(1.62,+$GET(X),0)),U)
+2 ;
FCNS ; -- display functions
+1 NEW DITYP,DIEN,X0
+2 FOR DITYP="A","C","O","R"
Begin DoDot:1
+3 SET DIEN=0
FOR
SET DIEN=$ORDER(DIFCN(DITYP,DIEN))
if DIEN<1
QUIT
Begin DoDot:2
+4 SET X0=$GET(^DIAC(1.62,DIEN,0))
if X0=""
QUIT
+5 DO PG
if $DATA(DIRUT)
QUIT
WRITE !,"FUNCTION: "_$PIECE(X0,U)
+6 WRITE ?50,"TYPE: ",$$EXTERNAL^DILFD(1.62,.03,,$PIECE(X0,U,3))
+7 DO PG
if $DATA(DIRUT)
QUIT
WRITE !," DISPLAY NAME: "_$PIECE(X0,U,2)
+8 IF DITYP="R"
IF $LENGTH($PIECE(X0,U,4))
Begin DoDot:3
+9 NEW X
SET X=$PIECE(X0,U,4)
+10 WRITE ?44,"NULL VALUE: "_$SELECT(X="P":"PERMIT",X="D":"DENY",1:"")
End DoDot:3
+11 DO PG
if $DATA(DIRUT)
QUIT
WRITE !," EXECUTE CODE: "_$GET(^DIAC(1.62,DIEN,1))
+12 IF $ORDER(^DIAC(1.62,DIEN,2,0))
DO DESC(DIEN)
if $DATA(DIRUT)
QUIT
+13 DO PG
if $DATA(DIRUT)
QUIT
WRITE !
End DoDot:2
if $DATA(DIRUT)
QUIT
End DoDot:1
if $DATA(DIRUT)
QUIT
+14 QUIT
+15 ;
DESC(DA) ; -- write Function Description
+1 if '$ORDER(^DIAC(1.62,+$GET(DA),2,0))
QUIT
+2 NEW DII,X
+3 DO PG
if $DATA(DIRUT)
QUIT
WRITE !," DESCRIPTION: "
+4 SET DII=0
FOR
SET DII=$ORDER(^DIAC(1.62,DA,2,DII))
if DII<1
QUIT
SET X=$GET(^(DII,0))
DO PG
if $DATA(DIRUT)
QUIT
WRITE !?1,X
+5 QUIT
+6 ;
INIT ; -- Setup
+1 NEW %,%H,X,Y
+2 SET %H=$HOROLOG
DO YX^%DTC
+3 SET DIACHDR=$PIECE(Y,"@")_" "_$PIECE($PIECE(Y,"@",2),":",1,2)_" PAGE "
+4 SET DIACRT=$EXTRACT(IOST,1,2)="C-"
+5 KILL DIRUT,DUOUT,DTOUT
+6 QUIT
+7 ;
ACTION ; -- display action
+1 IF '$ORDER(^DIAC(1.61,"D",+DIPOL,0))
WRITE !,"APPLICATION ACTION: <none linked>",!
QUIT
+2 NEW X0,I,X,DIACT
+3 SET DIACT=0
FOR
SET DIACT=+$ORDER(^DIAC(1.61,"D",+DIPOL,DIACT))
if DIACT<1
QUIT
Begin DoDot:1
+4 SET X0=$GET(^DIAC(1.61,DIACT,0))
+5 WRITE !,"APPLICATION ACTION: ",$PIECE(X0,U),?50,"TYPE: ",$$ACTYP($PIECE(X0,U,4))
+6 WRITE !?13,"FILE#: ",$PIECE(X0,U,2),?46,"API NAME: ",$PIECE(X0,U,3)
+7 if $LENGTH($GET(^DIAC(1.61,DIACT,1)))
WRITE !," SHORT DESCRIPTION: ",^(1)
+8 if $LENGTH($GET(^DIAC(1.61,DIACT,5)))
WRITE !," AVAILABLE FIELDS: ",^(5)
+9 SET I=0
FOR
SET I=$ORDER(^DIAC(1.61,DIACT,5.1,I))
if I<1
QUIT
SET X0=$GET(^(I,0))
Begin DoDot:2
+10 SET X="("_$PIECE(X0,U)_$SELECT($PIECE(X0,U,3):","_$PIECE(X0,U,3),1:"")_")"
+11 WRITE !,$$RJ^XLFSTR(X,18)_": "_$PIECE(X0,U,4)
End DoDot:2
+12 WRITE !
End DoDot:1
+13 QUIT
+14 ;
ACTYP(X) ; -- return action type name
+1 NEW Y
SET X=$GET(X)
+2 SET Y=$SELECT(X="C":"CREATE",X="R":"READ",X="U":"UPDATE",X="D":"DELETE",1:"")
+3 QUIT Y
+4 ;
PG ; -- check line count for new page
+1 IF $Y+3'<IOSL
DO HEADER
if $DATA(DIRUT)
QUIT
+2 QUIT
+3 ;
+1 IF DIACRT
Begin DoDot:1
+2 NEW DIR,X,Y
+3 SET DIR(0)="E"
WRITE !
DO ^DIR
End DoDot:1
if $DATA(DIRUT)
QUIT
+4 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET (ZTSTOP,DIRUT)=1
QUIT
HDR1 ;first header for CRTs
+1 WRITE @IOF
HDR2 ;first header for non-CRTs
+1 SET DIACPG=$GET(DIACPG)+1
+2 ;I $G(DIACT),$L($G(^DIAC(1.61,+$G(DIACT),1))) W ^(1)
+3 WRITE !,$PIECE(DIPOL,U,2),?(IOM-$LENGTH(DIACHDR)-$LENGTH(DIACPG)-1),DIACHDR_DIACPG
+4 WRITE !,$TRANSLATE($JUSTIFY("",IOM-1)," ","-"),!
+5 QUIT
