PRCFACX1 ;WISC@ALTOONA/CTB-CODE SHEET STRING GENERATOR ;10/21/92 10:52 AM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;ENTRY POINT TO GENERATE CODE SHEET MESSAGE STRING
S U="^" K PRCFDEL,TERM S:'$D(DA) DA=PRCFA("CSDA") K Q,Q0,PRCFCS 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,"B",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 PRCFX=0,XL1=160,PRCFCS(PRCFX)="",S=";",C=",",DEL="." I $D(PRCHLOG) S DEL="",XL1=80
S:"ISM"[PRCFA("SYS") DEL="^"
S:"IRS"[PRCFA("SYS") DEL=""
S:"CAP"[PRCFA("SYS") DEL="^" K PRCF("OUT")
S:"LOG\IRS"[PRCFA("SYS") PRCF("OUT")=""
S N1=0 F PRCFI=1:1 S N1=$O(Q("MAPSTR",N1)) Q:'N1 F N2=1:1 Q:$P(Q("MAPSTR",N1),"\",N2)="" K A S A=$P(Q("MAPSTR",N1),"\",N2) D @($S(A'[",":"SINGLE",1:"MULTI")) Q:$D(TERM)
K PRCFI S:$E(PRCFCS(0),1)="." PRCFCS(0)=$P(PRCFCS(0),".",2,999)
F I=0:1:PRCFX I PRCFCS(I)["$","IRS\ISM"'[PRCFA("SYS") D A Q
F K=I+1:1:PRCFX K PRCFCS(K)
I '$D(DT) D NOW^%DTC S DT=X
S X=0 F I=-1:0 S I=$O(PRCFCS(I)) Q:I="" S X=X+1
L +^PRCF(423,DA):5 I '$T S X="Code Sheet file not available - File lock timeout.*" D MSG^PRCFQ G OUT
K ^PRCF(423,DA,"CODE") S ^PRCF(423,DA,"CODE",0)="^^"_X_U_X_U_DT_U_U
L -^PRCF(423,DA,"CODE") S N=-1 F I=1:1 S N=$O(PRCFCS(N)) Q:N="" S ^PRCF(423,DA,"CODE",I,0)=PRCFCS(N)
K %,A,B,C,DEL,I,K,N,N1,N2,POP,PRCF("OUT"),PRCFX,Q,S,X,XL1,Y Q
SINGLE N XX S B=$P(A,S,2,3),XX=$G(Q(+B)) S:XX="" 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"!(^(2.1)["PRCF(""OUT"")")) S Y=Q X ^(2.1) S Q=Y
S1 S PRCFCS(PRCFX)=PRCFCS(PRCFX)_$S($L(PRCFCS(PRCFX)):DEL,1:"")_Q
I $L(PRCFCS(PRCFX))>XL1 S PRCFCS(PRCFX+1)=$E(PRCFCS(PRCFX),XL1+1,999),PRCFCS(PRCFX)=$E(PRCFCS(PRCFX),1,XL1) S PRCFX=PRCFX+1 K QX1,QX2 I Q="$" S TERM=1 Q
Q
MULTI S A(0)=A,NODE1=""
;NOTE: The following will only work for multiple with a total length
;in a(zz)'s of no more then 255 characters
;
F ZZ=0:1 Q:'$D(A(ZZ)) I $E(A(ZZ),$L(A(ZZ)))="~" S A(ZZ)=$E(A(ZZ),1,$L(A(ZZ))-1),N1=$O(Q("MAPSTR",N1)) I N1]"" S:$E(Q("MAPSTR",N1))="~" A(ZZ+1)=$P(Q("MAPSTR",N1),"\",1),A(ZZ+1)=$P(A(ZZ+1),"~",2,99),N2=1
S:$D(A(1)) A(0)=A(0)_","_A(1) K A(1)
F ZZ=0,1 Q:'$D(A(ZZ)) D ;BEGIN ZZ LOOP
. S:NODE1="" NODE1=$P(A(ZZ),S,2) S D1=0,J1=2
. F DD1=0:0 S D1=$O(Q(NODE1,D1)) Q:'D1 D ;BEGIN D1 LOOP
. . F J1=2:1 Q:$P(A(ZZ),C,J1)="" D ;BEGIN J1 LOOP
. . . S A1=$P(A(ZZ),C,J1),B1=$P(A1,S,2,3) S:'$D(Q(NODE1,D1,+B1)) Q(NODE1,D1,+B1)="" D M2
. . . Q ;QUIT J1 LOOP
. . Q ;QUIT D1 LOOP
. Q ;QUIT ZZ LOOP
Q
M2 S Q=$P(Q(NODE1,D1,+B1),U,$P(B1,S,2)) D S1 Q
Q
D1 S J=0 F S J=$O(^PRCF(423,DA,I,J)) Q:'J S K=-1 F S K=$O(^PRCF(423,DA,I,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,PRCFCS,PRCFX,S,X,XL1 Q
A I PRCFCS(I)="$" S I=I-1,PRCFCS(I)=$E(PRCFCS(I),1,$L(PRCFCS(I))-1)_"$" Q
S PRCFCS(I)=$P(PRCFCS(I),"$",1),PRCFCS(I)=$E(PRCFCS(I),1,$L(PRCFCS(I))-1)_"$" Q
DEL ;KILL THE CODE SHEET AND CROSS REFERENCES
S DIK="^PRCF(423," D WAIT^PRCFYN,^DIK
W $C(7)," CODE SHEET DELETED " K K,X,DA S PRCFDEL="" G OUT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFACX1 3300 printed Dec 13, 2024@02:02:18 Page 2
PRCFACX1 ;WISC@ALTOONA/CTB-CODE SHEET STRING GENERATOR ;10/21/92 10:52 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;ENTRY POINT TO GENERATE CODE SHEET MESSAGE STRING
+3 SET U="^"
KILL PRCFDEL,TERM
if '$DATA(DA)
SET DA=PRCFA("CSDA")
KILL Q,Q0,PRCFCS
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
+4 SET Q=$PIECE(Q(0),U,3)
SET Q=$EXTRACT(Q,2,($LENGTH(Q)-1))
SET Q("MAP")=$ORDER(^PRCD(422,"B",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)
+5 SET PRCFX=0
SET XL1=160
SET PRCFCS(PRCFX)=""
SET S=";"
SET C=","
SET DEL="."
IF $DATA(PRCHLOG)
SET DEL=""
SET XL1=80
+6 if "ISM"[PRCFA("SYS")
SET DEL="^"
+7 if "IRS"[PRCFA("SYS")
SET DEL=""
+8 if "CAP"[PRCFA("SYS")
SET DEL="^"
KILL PRCF("OUT")
+9 if "LOG\IRS"[PRCFA("SYS")
SET PRCF("OUT")=""
+10 SET N1=0
FOR PRCFI=1:1
SET N1=$ORDER(Q("MAPSTR",N1))
if 'N1
QUIT
FOR N2=1:1
if $PIECE(Q("MAPSTR",N1),"\",N2)=""
QUIT
KILL A
SET A=$PIECE(Q("MAPSTR",N1),"\",N2)
DO @($SELECT(A'[",":"SINGLE",1:"MULTI"))
if $DATA(TERM)
QUIT
+11 KILL PRCFI
if $EXTRACT(PRCFCS(0),1)="."
SET PRCFCS(0)=$PIECE(PRCFCS(0),".",2,999)
+12 FOR I=0:1:PRCFX
IF PRCFCS(I)["$"
IF "IRS\ISM"'[PRCFA("SYS")
DO A
QUIT
+13 FOR K=I+1:1:PRCFX
KILL PRCFCS(K)
+14 IF '$DATA(DT)
DO NOW^%DTC
SET DT=X
+15 SET X=0
FOR I=-1:0
SET I=$ORDER(PRCFCS(I))
if I=""
QUIT
SET X=X+1
+16 LOCK +^PRCF(423,DA):5
IF '$TEST
SET X="Code Sheet file not available - File lock timeout.*"
DO MSG^PRCFQ
GOTO OUT
+17 KILL ^PRCF(423,DA,"CODE")
SET ^PRCF(423,DA,"CODE",0)="^^"_X_U_X_U_DT_U_U
+18 LOCK -^PRCF(423,DA,"CODE")
SET N=-1
FOR I=1:1
SET N=$ORDER(PRCFCS(N))
if N=""
QUIT
SET ^PRCF(423,DA,"CODE",I,0)=PRCFCS(N)
+19 KILL %,A,B,C,DEL,I,K,N,N1,N2,POP,PRCF("OUT"),PRCFX,Q,S,X,XL1,Y
QUIT
SINGLE NEW XX
SET B=$PIECE(A,S,2,3)
SET XX=$GET(Q(+B))
if XX=""
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"!(^(2.1)["PRCF(""OUT"")"))
SET Y=Q
XECUTE ^(2.1)
SET Q=Y
S1 SET PRCFCS(PRCFX)=PRCFCS(PRCFX)_$SELECT($LENGTH(PRCFCS(PRCFX)):DEL,1:"")_Q
+1 IF $LENGTH(PRCFCS(PRCFX))>XL1
SET PRCFCS(PRCFX+1)=$EXTRACT(PRCFCS(PRCFX),XL1+1,999)
SET PRCFCS(PRCFX)=$EXTRACT(PRCFCS(PRCFX),1,XL1)
SET PRCFX=PRCFX+1
KILL QX1,QX2
IF Q="$"
SET TERM=1
QUIT
+2 QUIT
MULTI SET A(0)=A
SET NODE1=""
+1 ;NOTE: The following will only work for multiple with a total length
+2 ;in a(zz)'s of no more then 255 characters
+3 ;
+4 FOR ZZ=0:1
if '$DATA(A(ZZ))
QUIT
IF $EXTRACT(A(ZZ),$LENGTH(A(ZZ)))="~"
SET A(ZZ)=$EXTRACT(A(ZZ),1,$LENGTH(A(ZZ))-1)
SET N1=$ORDER(Q("MAPSTR",N1))
IF N1]""
if $EXTRACT(Q("MAPSTR",N1))="~"
SET A(ZZ+1)=$PIECE(Q("MAPSTR",N1),"\",1)
SET A(ZZ+1)=$PIECE(A(ZZ+1),"~",2,99)
SET N2=1
+5 if $DATA(A(1))
SET A(0)=A(0)_","_A(1)
KILL A(1)
+6 ;BEGIN ZZ LOOP
FOR ZZ=0,1
if '$DATA(A(ZZ))
QUIT
Begin DoDot:1
+7 if NODE1=""
SET NODE1=$PIECE(A(ZZ),S,2)
SET D1=0
SET J1=2
+8 ;BEGIN D1 LOOP
FOR DD1=0:0
SET D1=$ORDER(Q(NODE1,D1))
if 'D1
QUIT
Begin DoDot:2
+9 ;BEGIN J1 LOOP
FOR J1=2:1
if $PIECE(A(ZZ),C,J1)=""
QUIT
Begin DoDot:3
+10 SET A1=$PIECE(A(ZZ),C,J1)
SET B1=$PIECE(A1,S,2,3)
if '$DATA(Q(NODE1,D1,+B1))
SET Q(NODE1,D1,+B1)=""
DO M2
+11 ;QUIT J1 LOOP
QUIT
End DoDot:3
+12 ;QUIT D1 LOOP
QUIT
End DoDot:2
+13 ;QUIT ZZ LOOP
QUIT
End DoDot:1
+14 QUIT
M2 SET Q=$PIECE(Q(NODE1,D1,+B1),U,$PIECE(B1,S,2))
DO S1
QUIT
+1 QUIT
D1 SET J=0
FOR
SET J=$ORDER(^PRCF(423,DA,I,J))
if 'J
QUIT
SET K=-1
FOR
SET K=$ORDER(^PRCF(423,DA,I,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,PRCFCS,PRCFX,S,X,XL1
QUIT
A IF PRCFCS(I)="$"
SET I=I-1
SET PRCFCS(I)=$EXTRACT(PRCFCS(I),1,$LENGTH(PRCFCS(I))-1)_"$"
QUIT
+1 SET PRCFCS(I)=$PIECE(PRCFCS(I),"$",1)
SET PRCFCS(I)=$EXTRACT(PRCFCS(I),1,$LENGTH(PRCFCS(I))-1)_"$"
QUIT
DEL ;KILL THE CODE SHEET AND CROSS REFERENCES
+1 SET DIK="^PRCF(423,"
DO WAIT^PRCFYN
DO ^DIK
+2 WRITE $CHAR(7)," CODE SHEET DELETED "
KILL K,X,DA
SET PRCFDEL=""
GOTO OUT
+3 QUIT
