PRCFACR4 ;WISC@ALTOONA/CTB-EDIT CODE SHEET CODE ;4/15/93 13:08
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
KILL S DIK=DIC D WAIT^PRCFYN,^DIK W " <CODE SHEET DELETED>",$C(7) R X:3 K DIK
OUT K %,%H,D0,DA,DIC,DIE,DQ,DR,DWLW,I,J,K,LN,LNTH,N,PRCFA,Q,Q1,X,X1,Y,Z Q
EDIT ;EDIT THE CODE OF AN EXISTING CODE SHEET
K PRCFDEL S PRCF("X")="AS" D ^PRCFSITE G:'% OUT
S:'$D(PRCFASYS) PRCFASYS="FEEFENIRSCLI" S DIC="^PRCF(423,",DIC(0)="AEMNQZ",DIC("S")="S ZX=^(0) I $P(ZX,U,10)]"""",PRCFASYS[$P(ZX,U,10),$P(ZX,U,2)=PRC(""SITE"")" D ^DIC K DIC("A"),DIC("S") I Y<0 K PRCFASYS G OUT
I $P(Y(0),U)["KP"!($P(Y(0),U)["BCH") G ED
I '$D(^PRCF(423,+Y,"CODE")) W $C(7),!,"This code sheet may not be edited until it has been released for transmission." D OUT G EDIT
S DIE=DIC,(PRCFA("CSDA"),DA)=+Y
Q2 W !,$C(7) S %A="This Code Sheet will no longer be editable using the standard option."
Q3 S %A(1)="OK to Continue",%=1 D Q4,^PRCFYN G:%<0!(%=2) EDIT
S DIE=DIC,X="KP-"_$P(Y(0),"^"),(PRCFA("CSDA"),DA)=+Y,X1=X,DR=".01////"_X_";.3///@",PRCFA("Y0")=Y(0) D ^DIE W " ID has been changed to ",X1 K X1 S Y=DA
ED S:$D(PRCFA("Y0")) Y(0)=PRCFA("Y0") S PRCFA("TTLEN")=$P(Y(0),"^",8),PRCFA("SYS")=$P(Y(0),"^",10),DIE=DIC,(PRCFA("CSDA"),DA)=+Y
I $D(^PRCF(423,DA,"CODE")) S A3=$P(^PRCF(423,DA,"CODE",0),"^",3)
I $D(A3),A3>0 S N=0 K Q1 F I=1:1 S N=$O(^PRCF(423,DA,"CODE",N)) Q:+N=0 S Q1(I)=^PRCF(423,DA,"CODE",N,0)
K A3 S N=0,LNTH=70 D RENUM^PRCFACR3
S N=0 F I=1:1 S N=$O(Q1(N)) Q:+N=0 S ^PRCF(423,DA,"KEY",I,0)=Q1(N)
D NOW^%DTC S ^PRCF(423,DA,"KEY",0)="^^"_I-1_"^"_I-1_"^"_%
ED1 S DR=112 D ^DIE S N=0,LNTH=80 D RE1^PRCFACR3,XM^PRCFACR3,XM^PRCFACXM G EDIT
Q4 S %B="Answering 'YES' to this option will cause the Code Sheet ID to be changed.",%B(1)="This change will cause the Code Sheet to be uneditable using standard edit",%B(2)="options." Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFACR4 1889 printed Dec 13, 2024@02:02:12 Page 2
PRCFACR4 ;WISC@ALTOONA/CTB-EDIT CODE SHEET CODE ;4/15/93 13:08
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
KILL SET DIK=DIC
DO WAIT^PRCFYN
DO ^DIK
WRITE " <CODE SHEET DELETED>",$CHAR(7)
READ X:3
KILL DIK
OUT KILL %,%H,D0,DA,DIC,DIE,DQ,DR,DWLW,I,J,K,LN,LNTH,N,PRCFA,Q,Q1,X,X1,Y,Z
QUIT
EDIT ;EDIT THE CODE OF AN EXISTING CODE SHEET
+1 KILL PRCFDEL
SET PRCF("X")="AS"
DO ^PRCFSITE
if '%
GOTO OUT
+2 if '$DATA(PRCFASYS)
SET PRCFASYS="FEEFENIRSCLI"
SET DIC="^PRCF(423,"
SET DIC(0)="AEMNQZ"
SET DIC("S")="S ZX=^(0) I $P(ZX,U,10)]"""",PRCFASYS[$P(ZX,U,10),$P(ZX,U,2)=PRC(""SITE"")"
DO ^DIC
KILL DIC("A"),DIC("S")
IF Y<0
KILL PRCFASYS
GOTO OUT
+3 IF $PIECE(Y(0),U)["KP"!($PIECE(Y(0),U)["BCH")
GOTO ED
+4 IF '$DATA(^PRCF(423,+Y,"CODE"))
WRITE $CHAR(7),!,"This code sheet may not be edited until it has been released for transmission."
DO OUT
GOTO EDIT
+5 SET DIE=DIC
SET (PRCFA("CSDA"),DA)=+Y
Q2 WRITE !,$CHAR(7)
SET %A="This Code Sheet will no longer be editable using the standard option."
Q3 SET %A(1)="OK to Continue"
SET %=1
DO Q4
DO ^PRCFYN
if %<0!(%=2)
GOTO EDIT
+1 SET DIE=DIC
SET X="KP-"_$PIECE(Y(0),"^")
SET (PRCFA("CSDA"),DA)=+Y
SET X1=X
SET DR=".01////"_X_";.3///@"
SET PRCFA("Y0")=Y(0)
DO ^DIE
WRITE " ID has been changed to ",X1
KILL X1
SET Y=DA
ED if $DATA(PRCFA("Y0"))
SET Y(0)=PRCFA("Y0")
SET PRCFA("TTLEN")=$PIECE(Y(0),"^",8)
SET PRCFA("SYS")=$PIECE(Y(0),"^",10)
SET DIE=DIC
SET (PRCFA("CSDA"),DA)=+Y
+1 IF $DATA(^PRCF(423,DA,"CODE"))
SET A3=$PIECE(^PRCF(423,DA,"CODE",0),"^",3)
+2 IF $DATA(A3)
IF A3>0
SET N=0
KILL Q1
FOR I=1:1
SET N=$ORDER(^PRCF(423,DA,"CODE",N))
if +N=0
QUIT
SET Q1(I)=^PRCF(423,DA,"CODE",N,0)
+3 KILL A3
SET N=0
SET LNTH=70
DO RENUM^PRCFACR3
+4 SET N=0
FOR I=1:1
SET N=$ORDER(Q1(N))
if +N=0
QUIT
SET ^PRCF(423,DA,"KEY",I,0)=Q1(N)
+5 DO NOW^%DTC
SET ^PRCF(423,DA,"KEY",0)="^^"_I-1_"^"_I-1_"^"_%
ED1 SET DR=112
DO ^DIE
SET N=0
SET LNTH=80
DO RE1^PRCFACR3
DO XM^PRCFACR3
DO XM^PRCFACXM
GOTO EDIT
Q4 SET %B="Answering 'YES' to this option will cause the Code Sheet ID to be changed."
SET %B(1)="This change will cause the Code Sheet to be uneditable using standard edit"
SET %B(2)="options."
QUIT
