- 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 Jan 18, 2025@03:03:34 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