- 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 Feb 18, 2025@23:28:41 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