PRCFACX5 ;WISC@ALTOONA/CTB-BUILD OUTPUT MAP ;4/12/93 14:15
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
ONE ;BUILD MAP FOR ONE TEMPLATE
K MAP,Q S:$D(PRCF("X")) X=PRCF("X")
S MAP=1,MAP(1)="",DIC("A")="Select Template Name: ",DIC=.402,DIC(0)=$S($D(PRCF("X")):"M",1:"AEM"),DIC("S")="S ZXX=^(0) I $P(ZXX,U,4)=423,""PRCH""=$E(ZXX,1,4)!(""PRCFA TT""=$E(ZXX,1,8))!(""PRCA""=$E(ZXX,1,4))" D ^DIC K DIC,ZXX G:Y<0 OUT
S X=$P(Y,"^",2),Y=$O(^PRCD(422,"B",X,0)) I Y="" S DIC(0)="LM",(DIC,DLAYGO)=422 D ^DIC K DIC,DLAYGO G:+Y<0 OUT
S DA=+Y D BUILD I $D(PRCF("X")) K PRCF("X") G OUT
S X="---Done---" D MSG^PRCFQ G ONE
ALL ;REBUILD ALL MAPS
S %A="This program deletes all template maps and recreates them from the",%A(1)="input templates found in file 420.4. OK to continue",%B="" D ^PRCFYN Q:%'=1
INIT ;ENTRY POINT TO INITIALIZE ALL MAPS WITHOUT INTERACTION
K ^TMP($J) S A=$P(^PRCD(422,0),"^",1,2) K ^PRCD(422) S ^PRCD(422,0)=A K A
W ! S TEM=0 F XI=1:1 S TEM=$O(^PRCD(420.4,TEM)) Q:'TEM W "." S X=$P(^(TEM,0),"^",3) I X]"" S X=$P($P(X,"]"),"[",2) I '$D(^TMP($J,X)) D A
K ^TMP($J) Q
A S (DIC,DLAYGO)=422,DIC(0)="MZL" D ^DIC K DLAYGO I Y>0,$P(Y,"^",3)=1 W !,Y(0,0) S ^TMP($J,X)="" K MAP,Q S MAP=1,MAP(1)="" S DA=+Y D BUILD K C,DA,I,Y Q
Q
OUT K PRCF("X"),C,D0,D1,DA,DDD,DIC,DIE,DIR,DR,I,IOY,MAP,M,POP,X,Y,Z Q
BUILD S X=$P(^PRCD(422,DA,0),"^"),DIC=.402,DIC(0)="X" D ^DIC K DIC I Y<0 S X="Unable to locate template in file .402, no action taken.*" D MSG^PRCFQ Q
S DIEDA=+Y
F I=0:0 S I=$O(^DIE(DIEDA,"DR",I)) Q:I="" F M=0:0 S M=$O(^DIE(DIEDA,"DR",I,M)) Q:M="" S Q("DRSTRING",I,M)=^DIE(DIEDA,"DR",I,M) F N=0:0 S N=$O(^DIE(DIEDA,"DR",I,M,N)) Q:'N S Q("DRSTRING",I,M,N)=^(N)
S STRING=Q("DRSTRING",1,423) D X S N=0 F J=1:1 S N=$O(Q("DRSTRING",1,423,N)) Q:'N S STRING=Q("DRSTRING",1,423,N) D X
K ^PRCD(422,DA,1) S N=0 F I=1:1 S N=$O(MAP(N)) Q:'N S ^PRCD(422,DA,1,N,0)=MAP(N)
S ^PRCD(422,DA,1,0)="^422.01A^"_(I-1)_"^"_(I-1)
K A,B,C,DA,DIEDA,I,J,M,N,Q,STR,STRING,X,Y
Q
;S N=0,N=$O(^DIE(DA,"DR",I,M,N)) Q:N="" S Q("DRSTRING",I,N)=^(N)
Q
SINGLE S B=$P(B,U,3),X=+A I $D(^DD(423,+A,2.1)),^(2.1)["PRCHLOG"!(^(2.1)["PRCF(""OUT"")") S X=X_"T"
S X=X_";"_B_"\" I $L(MAP(MAP))+$L(X)>200 S MAP=MAP+1,MAP(MAP)=""
S MAP(MAP)=MAP(MAP)_X
Q
MULTI S X=A_";"_+$P(B,"^",3)_";"_+B,STR=Q("DRSTRING",2,+B) D
. I $L(MAP(MAP))+$L(X)>200 S MAP=MAP+1,MAP(MAP)=""
. S MAP(MAP)=MAP(MAP)_X S X=""
. Q
F JJ=1:1 S AA=$P(STR,";",JJ) Q:AA="" I +AA>0,$D(^DD(+B,+AA,0)) D
. S BB=$P(^DD(+B,+AA,0),"^",4),X=","_+AA_";"_BB
. I $L(MAP(MAP)_X)>200 S MAP(MAP)=MAP(MAP)_"~",X="~"_$P(X,",",2,999),MAP=MAP+1,MAP(MAP)=""
. S MAP(MAP)=MAP(MAP)_X
. Q
S MAP(MAP)=MAP(MAP)_"\" K II,JJ,AA,BB Q
X F I=1:1 S A=$P(STRING,";",I) Q:A="" I +A>0,$D(^DD(423,+A,0)) S B=$P(^(0),"^",2,4),B(3)=$S(+$P(B,U)=0:"SINGLE",1:"MULTI") D @(B(3))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFACX5 2892 printed Nov 22, 2024@17:12:26 Page 2
PRCFACX5 ;WISC@ALTOONA/CTB-BUILD OUTPUT MAP ;4/12/93 14:15
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
ONE ;BUILD MAP FOR ONE TEMPLATE
+1 KILL MAP,Q
if $DATA(PRCF("X"))
SET X=PRCF("X")
+2 SET MAP=1
SET MAP(1)=""
SET DIC("A")="Select Template Name: "
SET DIC=.402
SET DIC(0)=$SELECT($DATA(PRCF("X")):"M",1:"AEM")
SET DIC("S")="S ZXX=^(0) I $P(ZXX,U,4)=423,""PRCH""=$E(ZXX,1,4)!(""PRCFA TT""=$E(ZXX,1,8))!(""PRCA""=$E(ZXX,1,4))"
DO ^DIC
KILL DIC,ZXX
if Y<0
GOTO OUT
+3 SET X=$PIECE(Y,"^",2)
SET Y=$ORDER(^PRCD(422,"B",X,0))
IF Y=""
SET DIC(0)="LM"
SET (DIC,DLAYGO)=422
DO ^DIC
KILL DIC,DLAYGO
if +Y<0
GOTO OUT
+4 SET DA=+Y
DO BUILD
IF $DATA(PRCF("X"))
KILL PRCF("X")
GOTO OUT
+5 SET X="---Done---"
DO MSG^PRCFQ
GOTO ONE
ALL ;REBUILD ALL MAPS
+1 SET %A="This program deletes all template maps and recreates them from the"
SET %A(1)="input templates found in file 420.4. OK to continue"
SET %B=""
DO ^PRCFYN
if %'=1
QUIT
INIT ;ENTRY POINT TO INITIALIZE ALL MAPS WITHOUT INTERACTION
+1 KILL ^TMP($JOB)
SET A=$PIECE(^PRCD(422,0),"^",1,2)
KILL ^PRCD(422)
SET ^PRCD(422,0)=A
KILL A
+2 WRITE !
SET TEM=0
FOR XI=1:1
SET TEM=$ORDER(^PRCD(420.4,TEM))
if 'TEM
QUIT
WRITE "."
SET X=$PIECE(^(TEM,0),"^",3)
IF X]""
SET X=$PIECE($PIECE(X,"]"),"[",2)
IF '$DATA(^TMP($JOB,X))
DO A
+3 KILL ^TMP($JOB)
QUIT
A SET (DIC,DLAYGO)=422
SET DIC(0)="MZL"
DO ^DIC
KILL DLAYGO
IF Y>0
IF $PIECE(Y,"^",3)=1
WRITE !,Y(0,0)
SET ^TMP($JOB,X)=""
KILL MAP,Q
SET MAP=1
SET MAP(1)=""
SET DA=+Y
DO BUILD
KILL C,DA,I,Y
QUIT
+1 QUIT
OUT KILL PRCF("X"),C,D0,D1,DA,DDD,DIC,DIE,DIR,DR,I,IOY,MAP,M,POP,X,Y,Z
QUIT
BUILD SET X=$PIECE(^PRCD(422,DA,0),"^")
SET DIC=.402
SET DIC(0)="X"
DO ^DIC
KILL DIC
IF Y<0
SET X="Unable to locate template in file .402, no action taken.*"
DO MSG^PRCFQ
QUIT
+1 SET DIEDA=+Y
+2 FOR I=0:0
SET I=$ORDER(^DIE(DIEDA,"DR",I))
if I=""
QUIT
FOR M=0:0
SET M=$ORDER(^DIE(DIEDA,"DR",I,M))
if M=""
QUIT
SET Q("DRSTRING",I,M)=^DIE(DIEDA,"DR",I,M)
FOR N=0:0
SET N=$ORDER(^DIE(DIEDA,"DR",I,M,N))
if 'N
QUIT
SET Q("DRSTRING",I,M,N)=^(N)
+3 SET STRING=Q("DRSTRING",1,423)
DO X
SET N=0
FOR J=1:1
SET N=$ORDER(Q("DRSTRING",1,423,N))
if 'N
QUIT
SET STRING=Q("DRSTRING",1,423,N)
DO X
+4 KILL ^PRCD(422,DA,1)
SET N=0
FOR I=1:1
SET N=$ORDER(MAP(N))
if 'N
QUIT
SET ^PRCD(422,DA,1,N,0)=MAP(N)
+5 SET ^PRCD(422,DA,1,0)="^422.01A^"_(I-1)_"^"_(I-1)
+6 KILL A,B,C,DA,DIEDA,I,J,M,N,Q,STR,STRING,X,Y
+7 QUIT
+8 ;S N=0,N=$O(^DIE(DA,"DR",I,M,N)) Q:N="" S Q("DRSTRING",I,N)=^(N)
+9 QUIT
SINGLE SET B=$PIECE(B,U,3)
SET X=+A
IF $DATA(^DD(423,+A,2.1))
IF ^(2.1)["PRCHLOG"!(^(2.1)["PRCF(""OUT"")")
SET X=X_"T"
+1 SET X=X_";"_B_"\"
IF $LENGTH(MAP(MAP))+$LENGTH(X)>200
SET MAP=MAP+1
SET MAP(MAP)=""
+2 SET MAP(MAP)=MAP(MAP)_X
+3 QUIT
MULTI SET X=A_";"_+$PIECE(B,"^",3)_";"_+B
SET STR=Q("DRSTRING",2,+B)
Begin DoDot:1
+1 IF $LENGTH(MAP(MAP))+$LENGTH(X)>200
SET MAP=MAP+1
SET MAP(MAP)=""
+2 SET MAP(MAP)=MAP(MAP)_X
SET X=""
+3 QUIT
End DoDot:1
+4 FOR JJ=1:1
SET AA=$PIECE(STR,";",JJ)
if AA=""
QUIT
IF +AA>0
IF $DATA(^DD(+B,+AA,0))
Begin DoDot:1
+5 SET BB=$PIECE(^DD(+B,+AA,0),"^",4)
SET X=","_+AA_";"_BB
+6 IF $LENGTH(MAP(MAP)_X)>200
SET MAP(MAP)=MAP(MAP)_"~"
SET X="~"_$PIECE(X,",",2,999)
SET MAP=MAP+1
SET MAP(MAP)=""
+7 SET MAP(MAP)=MAP(MAP)_X
+8 QUIT
End DoDot:1
+9 SET MAP(MAP)=MAP(MAP)_"\"
KILL II,JJ,AA,BB
QUIT
X FOR I=1:1
SET A=$PIECE(STRING,";",I)
if A=""
QUIT
IF +A>0
IF $DATA(^DD(423,+A,0))
SET B=$PIECE(^(0),"^",2,4)
SET B(3)=$SELECT(+$PIECE(B,U)=0:"SINGLE",1:"MULTI")
DO @(B(3))
