PRCFACXL ;WISC@ALTOONA/CTB-LOG CODE SHEET STRING GENERATOR ;10 Sep 89/3:08 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
S U="^" K PRCFDEL,TERM S:'$D(DA) DA=PRCFA("CSDA") K Q,Q0,Q1 F I=-1:0 S I=$O(^PRCF(423,DA,I)) Q:I=""!(I'=+I) S:$D(^(I))'["0" Q(I)=^(I) I $D(^PRCF(423,DA,I,0)) D D1
S Q=$P(Q(0),U,3),Q=$E(Q,2,($L(Q)-1)),Q("MAP")=$O(^PRCD(422,"AD",Q,0)) F I=0:0 S I=$O(^PRCD(422,Q("MAP"),1,I)) Q:I="" S:$D(^(I,0)) Q("MAPSTR",I)=^(0)
S X=0,XL1=81,Q1(X)="",S=";",C=",",DEL="." I $D(PRCHLOG) S DEL="",XL1=80
S N1=0 F I=1:1 S N1=$O(Q("MAPSTR",N1)) Q:'N1 F N2=1:1 Q:$P(Q("MAPSTR",N1),"\",N2)="" S A=$P(Q("MAPSTR",N1),"\",N2) D @($S(A'[",":"SINGLE",1:"MULTI")) Q:$D(TERM)
S:$E(Q1(0),1)="." Q1(0)=$P(Q1(0),".",2,999)
F I=0:1:X I Q1(I)["$" D A Q
F K=I+1:1:X K Q1(K)
TRANSMIT G:'$D(^PRCF(423,DA,"TRANS")) ^PRCFACX0 I $D(^PRCF(423,DA,"TRANS")),$P(^("TRANS"),U,1)'="Y" G ^PRCFACX0
S ^PRCF(423,DA,"TRANS")="N"
W $C(7) S %A="THIS CODE SHEET HAS ALREADY BEEN PRINTED.",%A(1)="DO YOU WISH TO RETRANSMIT IT",%B="'YES' to mark for retransmission.",%B(1)="'NO' or '^' to hold in file."
S %=2 D ^PRCFYN I %'=1 W !,$C(7),"NO ACTION TAKEN " R X:3 K PRCFA("PODA") Q
S DR=".3////N;.4///@",DIE="^PRCF(423," D ^DIE
G ^PRCFACX0
SINGLE S B=$P(A,S,2,3) S:'$D(Q(+B)) Q(+B)="" S Q=$P(Q(+B),U,$P(B,S,2))
I $P(A,S)["T",$D(^DD(423,+A,2.1)),^(2.1)["PRCHLOG" S Y=Q X ^(2.1) S Q=Y
S1 S Q1(X)=Q1(X)_DEL_Q I $L(Q1(X))>XL1 S Q1(X+1)=$E(Q1(X),XL1+1,999),Q1(X)=$E(Q1(X),1,XL1) S X=X+1,XL1=80 K QX1,QX2 I Q="$" S TERM=1 Q
Q
MULTI S NODE1=$P(A,S,2) F D1=0:0 S D1=$O(Q(NODE1,D1)) Q:'D1 F J1=2:1 Q:$P(A,C,J1)="" S A1=$P(A,C,J1),B1=$P(A1,S,2,3) S:'$D(Q(NODE1,D1,+B1)) Q(NODE1,D1+B1)="" D M2
Q
M2 S Q=$P(Q(NODE1,D1,+B1),U,$P(B1,S,2)) D S1 Q
Q
D1 F J=0:0 S J=$O(^PRCF(423,DA,I,J)) Q:'J F K=-1:0 S K=$O(^(J,K)) Q:K=""!(K'=+K) S:$D(^PRCF(423,DA,I,J,K)) Q(I,J,K)=^(K)
Q
OUT K B,D,D0,DG,DIC,DIE,DIG,DIH,DIU,DIV,DIW,DLAYGO,DR,K,Q,Q1,S,X,XL1 Q
A I Q1(I)="$" S I=I-1,Q1(I)=$E(Q1(I),1,$L(Q1(I))-1)_"$" Q
S Q1(I)=$P(Q1(I),"$",1),Q1(I)=$E(Q1(I),1,$L(Q1(I))-1)_"$" Q
DEL ;KILL THE CODE SHEET AND CROSS REFERENCES
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFACXL 2163 printed Dec 13, 2024@02:02:21 Page 2
PRCFACXL ;WISC@ALTOONA/CTB-LOG CODE SHEET STRING GENERATOR ;10 Sep 89/3:08 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 SET U="^"
KILL PRCFDEL,TERM
if '$DATA(DA)
SET DA=PRCFA("CSDA")
KILL Q,Q0,Q1
FOR I=-1:0
SET I=$ORDER(^PRCF(423,DA,I))
if I=""!(I'=+I)
QUIT
if $DATA(^(I))'["0"
SET Q(I)=^(I)
IF $DATA(^PRCF(423,DA,I,0))
DO D1
+3 SET Q=$PIECE(Q(0),U,3)
SET Q=$EXTRACT(Q,2,($LENGTH(Q)-1))
SET Q("MAP")=$ORDER(^PRCD(422,"AD",Q,0))
FOR I=0:0
SET I=$ORDER(^PRCD(422,Q("MAP"),1,I))
if I=""
QUIT
if $DATA(^(I,0))
SET Q("MAPSTR",I)=^(0)
+4 SET X=0
SET XL1=81
SET Q1(X)=""
SET S=";"
SET C=","
SET DEL="."
IF $DATA(PRCHLOG)
SET DEL=""
SET XL1=80
+5 SET N1=0
FOR I=1:1
SET N1=$ORDER(Q("MAPSTR",N1))
if 'N1
QUIT
FOR N2=1:1
if $PIECE(Q("MAPSTR",N1),"\",N2)=""
QUIT
SET A=$PIECE(Q("MAPSTR",N1),"\",N2)
DO @($SELECT(A'[",":"SINGLE",1:"MULTI"))
if $DATA(TERM)
QUIT
+6 if $EXTRACT(Q1(0),1)="."
SET Q1(0)=$PIECE(Q1(0),".",2,999)
+7 FOR I=0:1:X
IF Q1(I)["$"
DO A
QUIT
+8 FOR K=I+1:1:X
KILL Q1(K)
TRANSMIT if '$DATA(^PRCF(423,DA,"TRANS"))
GOTO ^PRCFACX0
IF $DATA(^PRCF(423,DA,"TRANS"))
IF $PIECE(^("TRANS"),U,1)'="Y"
GOTO ^PRCFACX0
+1 SET ^PRCF(423,DA,"TRANS")="N"
+2 WRITE $CHAR(7)
SET %A="THIS CODE SHEET HAS ALREADY BEEN PRINTED."
SET %A(1)="DO YOU WISH TO RETRANSMIT IT"
SET %B="'YES' to mark for retransmission."
SET %B(1)="'NO' or '^' to hold in file."
+3 SET %=2
DO ^PRCFYN
IF %'=1
WRITE !,$CHAR(7),"NO ACTION TAKEN "
READ X:3
KILL PRCFA("PODA")
QUIT
+4 SET DR=".3////N;.4///@"
SET DIE="^PRCF(423,"
DO ^DIE
+5 GOTO ^PRCFACX0
SINGLE SET B=$PIECE(A,S,2,3)
if '$DATA(Q(+B))
SET Q(+B)=""
SET Q=$PIECE(Q(+B),U,$PIECE(B,S,2))
+1 IF $PIECE(A,S)["T"
IF $DATA(^DD(423,+A,2.1))
IF ^(2.1)["PRCHLOG"
SET Y=Q
XECUTE ^(2.1)
SET Q=Y
S1 SET Q1(X)=Q1(X)_DEL_Q
IF $LENGTH(Q1(X))>XL1
SET Q1(X+1)=$EXTRACT(Q1(X),XL1+1,999)
SET Q1(X)=$EXTRACT(Q1(X),1,XL1)
SET X=X+1
SET XL1=80
KILL QX1,QX2
IF Q="$"
SET TERM=1
QUIT
+1 QUIT
MULTI SET NODE1=$PIECE(A,S,2)
FOR D1=0:0
SET D1=$ORDER(Q(NODE1,D1))
if 'D1
QUIT
FOR J1=2:1
if $PIECE(A,C,J1)=""
QUIT
SET A1=$PIECE(A,C,J1)
SET B1=$PIECE(A1,S,2,3)
if '$DATA(Q(NODE1,D1,+B1))
SET Q(NODE1,D1+B1)=""
DO M2
+1 QUIT
M2 SET Q=$PIECE(Q(NODE1,D1,+B1),U,$PIECE(B1,S,2))
DO S1
QUIT
+1 QUIT
D1 FOR J=0:0
SET J=$ORDER(^PRCF(423,DA,I,J))
if 'J
QUIT
FOR K=-1:0
SET K=$ORDER(^(J,K))
if K=""!(K'=+K)
QUIT
if $DATA(^PRCF(423,DA,I,J,K))
SET Q(I,J,K)=^(K)
+1 QUIT
OUT KILL B,D,D0,DG,DIC,DIE,DIG,DIH,DIU,DIV,DIW,DLAYGO,DR,K,Q,Q1,S,X,XL1
QUIT
A IF Q1(I)="$"
SET I=I-1
SET Q1(I)=$EXTRACT(Q1(I),1,$LENGTH(Q1(I))-1)_"$"
QUIT
+1 SET Q1(I)=$PIECE(Q1(I),"$",1)
SET Q1(I)=$EXTRACT(Q1(I),1,$LENGTH(Q1(I))-1)_"$"
QUIT
DEL ;KILL THE CODE SHEET AND CROSS REFERENCES
