PRCFACXM ;WISC@ALTOONA/CTB-CODE SHEET STRING GENERATOR ;4/26/93 2:49 PM ; 4/26/93 11:48 AM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
D ^PRCFACX1
XM S PRCFX=+$P(^PRCF(423,PRCFA("CSDA"),"TRANS"),"^",15)
W !!,"TRANSMITTED CODE SHEET WILL BE AS FOLLOWS:" I 'PRCFX W !
;'$D(PRCHLOG),PRCFA("SYS")'="CAP" W !
E W !," 1 2 3 4 5 6 7 8" S Y="",$P(Y,"1234567890",9)="" W !,Y S Y="",$P(Y,"----+----|",9)="" W !,Y
S X="",X1=0 F I=1:1 S X=$O(PRCFCS(X)) Q:X="" W !,PRCFCS(X) S X1=X1+$L(PRCFCS(X))
I PRCFX I X1'=PRCFX W !!,$C(7),"Code sheet does not equal "_PRCFX_" characters.",! G EDIT
W ! S %A="Do you wish to TRANSMIT this Code Sheet to "_$S(PRCFA("SYS")="ISM":"ISMS",1:"LOG")
S %=1,%B="'YES' will mark the code sheet for transmission.",%B(1)="'NO' will give you a chance to edit the code sheet."
S %B(2)="'^' will delete the code sheet." D ^PRCFYN G:%=1 TRANSMIT G:%<0 DEL
EDIT S %A="Do you want to edit this Code Sheet",%B="'YES' to edit, 'NO' or '^' for chance to delete code sheet."
S %=2 D ^PRCFYN I %'=1 S DA=PRCFA("CSDA") D DEL Q
S DA=PRCFA("CSDA"),DIE="^PRCF(423," K PRCFCS
S DR="" S:$D(PRCFA("EDIT")) DR=PRCFA("EDIT")
I $D(PRCFA("CSNAME")),PRCFA("CSNAME")["KP" S DR=112
I DR="" W !,"Error in editing this code sheet. Please re-enter.",$C(7) G DEL
D ^DIE I DR=112 D RE1^PRCFACR3,XM^PRCFACR3 G XM
G V
TRANSMIT G:'$D(^PRCF(423,DA,"TRANS")) ^PRCFACX0
I $D(^PRCF(423,DA,"TRANS")),$P(^("TRANS"),U,1)'="Y" G ^PRCFACX0
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
OUT K B,D,D0,DG,DIC,DIE,DIG,DIH,DIU,DIV,DIW,DLAYGO,DR,K,Q,PRCFCS,S,X,XL1 Q
DEL ;KILL THE CODE SHEET AND CROSS REFERENCES
S %A="Are you sure you want to delete this Code Sheet",%B="'YES' to delete, 'NO' or '^' to retain, but not transmit.",%=2 D ^PRCFYN I %'=1 S X=" <Code Sheet Retained in File>*" D MSG^PRCFQ S PRCFA("CSHOLD")="" Q
D WAIT^PRCFYN S DA=PRCFA("CSDA"),DIK="^PRCF(423," D ^DIK S X=" CODE SHEET DELETED*" D MSG^PRCFQ
K K,X,DA,PRCFA("CSNAME"),PRCFA("CSDA"),PRCFCS(0) S PRCFDEL="" G OUT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFACXM 2392 printed Oct 16, 2024@18:03:08 Page 2
PRCFACXM ;WISC@ALTOONA/CTB-CODE SHEET STRING GENERATOR ;4/26/93 2:49 PM ; 4/26/93 11:48 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 DO ^PRCFACX1
XM SET PRCFX=+$PIECE(^PRCF(423,PRCFA("CSDA"),"TRANS"),"^",15)
+1 WRITE !!,"TRANSMITTED CODE SHEET WILL BE AS FOLLOWS:"
IF 'PRCFX
WRITE !
+2 ;'$D(PRCHLOG),PRCFA("SYS")'="CAP" W !
+3 IF '$TEST
WRITE !," 1 2 3 4 5 6 7 8"
SET Y=""
SET $PIECE(Y,"1234567890",9)=""
WRITE !,Y
SET Y=""
SET $PIECE(Y,"----+----|",9)=""
WRITE !,Y
+4 SET X=""
SET X1=0
FOR I=1:1
SET X=$ORDER(PRCFCS(X))
if X=""
QUIT
WRITE !,PRCFCS(X)
SET X1=X1+$LENGTH(PRCFCS(X))
+5 IF PRCFX
IF X1'=PRCFX
WRITE !!,$CHAR(7),"Code sheet does not equal "_PRCFX_" characters.",!
GOTO EDIT
+6 WRITE !
SET %A="Do you wish to TRANSMIT this Code Sheet to "_$SELECT(PRCFA("SYS")="ISM":"ISMS",1:"LOG")
+7 SET %=1
SET %B="'YES' will mark the code sheet for transmission."
SET %B(1)="'NO' will give you a chance to edit the code sheet."
+8 SET %B(2)="'^' will delete the code sheet."
DO ^PRCFYN
if %=1
GOTO TRANSMIT
if %<0
GOTO DEL
EDIT SET %A="Do you want to edit this Code Sheet"
SET %B="'YES' to edit, 'NO' or '^' for chance to delete code sheet."
+1 SET %=2
DO ^PRCFYN
IF %'=1
SET DA=PRCFA("CSDA")
DO DEL
QUIT
+2 SET DA=PRCFA("CSDA")
SET DIE="^PRCF(423,"
KILL PRCFCS
+3 SET DR=""
if $DATA(PRCFA("EDIT"))
SET DR=PRCFA("EDIT")
+4 IF $DATA(PRCFA("CSNAME"))
IF PRCFA("CSNAME")["KP"
SET DR=112
+5 IF DR=""
WRITE !,"Error in editing this code sheet. Please re-enter.",$CHAR(7)
GOTO DEL
+6 DO ^DIE
IF DR=112
DO RE1^PRCFACR3
DO XM^PRCFACR3
GOTO XM
+7 GOTO V
TRANSMIT if '$DATA(^PRCF(423,DA,"TRANS"))
GOTO ^PRCFACX0
+1 IF $DATA(^PRCF(423,DA,"TRANS"))
IF $PIECE(^("TRANS"),U,1)'="Y"
GOTO ^PRCFACX0
+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
OUT KILL B,D,D0,DG,DIC,DIE,DIG,DIH,DIU,DIV,DIW,DLAYGO,DR,K,Q,PRCFCS,S,X,XL1
QUIT
DEL ;KILL THE CODE SHEET AND CROSS REFERENCES
+1 SET %A="Are you sure you want to delete this Code Sheet"
SET %B="'YES' to delete, 'NO' or '^' to retain, but not transmit."
SET %=2
DO ^PRCFYN
IF %'=1
SET X=" <Code Sheet Retained in File>*"
DO MSG^PRCFQ
SET PRCFA("CSHOLD")=""
QUIT
+2 DO WAIT^PRCFYN
SET DA=PRCFA("CSDA")
SET DIK="^PRCF(423,"
DO ^DIK
SET X=" CODE SHEET DELETED*"
DO MSG^PRCFQ
+3 KILL K,X,DA,PRCFA("CSNAME"),PRCFA("CSDA"),PRCFCS(0)
SET PRCFDEL=""
GOTO OUT
+4 QUIT
