- 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 Mar 13, 2025@21:07:08 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))
