PRCHCS8 ;WISC/RHD-EDIT DEPOT RECEIVING LOG CODE SHEETS ;12/1/93 09:53
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
EN S PRCHN("PO")=$P($P(^PRC(442,PRCHPO,0),"-",2),U,1),PRCFA("SYS")="LOG",PRCFA("REF")=PRCHN("PO"),PRCHAUTO="" W !," Now creating LOG code sheets ."
S DA=$P($G(^PRC(442,PRCHPO,11,PRCHRPT,1)),U,7)
I 'DA D ^PRCHCS1 Q:'$D(PRCFA) W "."
S:'$D(DA) DA="" I 'DA W !,"No code sheets created !",$C(7) K PRCHPO G Q
1 S PRCH=DA,IOP="" D:'$D(IOF) ^%ZIS W !! D HDR^PRCHCS0
11 I '$D(^PRCF(423,PRCH,300))!('$D(^("CODE",1,0))) D ERR1 G 3
S Y=^PRCF(423,PRCH,"CODE",1,0) W !,Y I $L(Y)'=80!($O(^PRCF(423,PRCH,"CODE",1))) D ERR^PRCHCS0 G 3
2 W ! S %A="Do you want to transmit this code sheet",%B="'YES' will mark the code sheets for transmission.",%B(1)="'NO' will give you a chance to edit code sheet."
S %B(2)="'^' will delete code sheet." D ^PRCFYN G TRAN:%=1,DEL1:%<0
3 S %A="Do you want to edit this code sheet",%B="'YES' to edit code sheet.",%B(1)="'NO' or '^' for chance to delete code sheet." D ^PRCFYN G DEL:%'=1
4 K PRCHLOG S DIE="^PRCF(423,",DA=PRCH,DR=PRCFA("EDIT") D ^DIE S PRCHLOG=1 D ^PRCFACX1
G 1
TRAN I '$D(DT) D NOW^%DTC S DT=$P(%,".",1)
S %DT="AEXF",%DT("A")="TRANSMISSION DATE: ",%DT("B")="TODAY",%DT(0)=DT D ^%DT G:Y<0 3 S PRCHDT=Y
D SIG^PRCHCS0 I '$D(PRCHNM) D:$D(PRCHLOG) DEL1 K PRCHPO G Q
S DA=PRCH,PRCHBTYP=5 D MRK^PRCHCS
W !!,$C(7),"CODE SHEET MARKED FOR TRANSMISSION!"
Q G Q^PRCHCS0
ERR1 W !?5,"Code sheet has not been completed and needs to be edited !",$C(7)
W !! S %A="Do you want to re-create the code sheet",%B="'YES' will rebuild the code sheet from the P.O. data as it was before",%B(1)="editing. Any other answer will do nothing.",%=1 D ^PRCFYN Q:%'=1
D ^PRCHCS1 Q:'$D(PRCFA) I $D(DA),DA S PRCH=DA
Q
DEL S %=1,%A="Delete code sheet for this "_$S(PRCHTYP="R":"Partial",1:"Order"),%B="'YES' or '^' to delete the code sheet.",%B(1)="'NO' to have another chance to transmit." D ^PRCFYN G:%=2 1
DEL1 ;DELETES ALL CODE SHEETS
S DIK="^PRCF(423,",DA=PRCH D ^DIK K DIK S DA="" D SETR^PRCHCS1
W !,"CODE SHEET DELETED FOR THIS "_$S(PRCHTYP="R":"PARTIAL",1:"ORDER")_" !",$C(7) K PRCHPO G Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHCS8 2205 printed Dec 13, 2024@02:06:24 Page 2
PRCHCS8 ;WISC/RHD-EDIT DEPOT RECEIVING LOG CODE SHEETS ;12/1/93 09:53
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN SET PRCHN("PO")=$PIECE($PIECE(^PRC(442,PRCHPO,0),"-",2),U,1)
SET PRCFA("SYS")="LOG"
SET PRCFA("REF")=PRCHN("PO")
SET PRCHAUTO=""
WRITE !," Now creating LOG code sheets ."
+1 SET DA=$PIECE($GET(^PRC(442,PRCHPO,11,PRCHRPT,1)),U,7)
+2 IF 'DA
DO ^PRCHCS1
if '$DATA(PRCFA)
QUIT
WRITE "."
+3 if '$DATA(DA)
SET DA=""
IF 'DA
WRITE !,"No code sheets created !",$CHAR(7)
KILL PRCHPO
GOTO Q
1 SET PRCH=DA
SET IOP=""
if '$DATA(IOF)
DO ^%ZIS
WRITE !!
DO HDR^PRCHCS0
11 IF '$DATA(^PRCF(423,PRCH,300))!('$DATA(^("CODE",1,0)))
DO ERR1
GOTO 3
+1 SET Y=^PRCF(423,PRCH,"CODE",1,0)
WRITE !,Y
IF $LENGTH(Y)'=80!($ORDER(^PRCF(423,PRCH,"CODE",1)))
DO ERR^PRCHCS0
GOTO 3
2 WRITE !
SET %A="Do you want to transmit this code sheet"
SET %B="'YES' will mark the code sheets for transmission."
SET %B(1)="'NO' will give you a chance to edit code sheet."
+1 SET %B(2)="'^' will delete code sheet."
DO ^PRCFYN
if %=1
GOTO TRAN
if %<0
GOTO DEL1
3 SET %A="Do you want to edit this code sheet"
SET %B="'YES' to edit code sheet."
SET %B(1)="'NO' or '^' for chance to delete code sheet."
DO ^PRCFYN
if %'=1
GOTO DEL
4 KILL PRCHLOG
SET DIE="^PRCF(423,"
SET DA=PRCH
SET DR=PRCFA("EDIT")
DO ^DIE
SET PRCHLOG=1
DO ^PRCFACX1
+1 GOTO 1
TRAN IF '$DATA(DT)
DO NOW^%DTC
SET DT=$PIECE(%,".",1)
+1 SET %DT="AEXF"
SET %DT("A")="TRANSMISSION DATE: "
SET %DT("B")="TODAY"
SET %DT(0)=DT
DO ^%DT
if Y<0
GOTO 3
SET PRCHDT=Y
+2 DO SIG^PRCHCS0
IF '$DATA(PRCHNM)
if $DATA(PRCHLOG)
DO DEL1
KILL PRCHPO
GOTO Q
+3 SET DA=PRCH
SET PRCHBTYP=5
DO MRK^PRCHCS
+4 WRITE !!,$CHAR(7),"CODE SHEET MARKED FOR TRANSMISSION!"
Q GOTO Q^PRCHCS0
ERR1 WRITE !?5,"Code sheet has not been completed and needs to be edited !",$CHAR(7)
+1 WRITE !!
SET %A="Do you want to re-create the code sheet"
SET %B="'YES' will rebuild the code sheet from the P.O. data as it was before"
SET %B(1)="editing. Any other answer will do nothing."
SET %=1
DO ^PRCFYN
if %'=1
QUIT
+2 DO ^PRCHCS1
if '$DATA(PRCFA)
QUIT
IF $DATA(DA)
IF DA
SET PRCH=DA
+3 QUIT
DEL SET %=1
SET %A="Delete code sheet for this "_$SELECT(PRCHTYP="R":"Partial",1:"Order")
SET %B="'YES' or '^' to delete the code sheet."
SET %B(1)="'NO' to have another chance to transmit."
DO ^PRCFYN
if %=2
GOTO 1
DEL1 ;DELETES ALL CODE SHEETS
+1 SET DIK="^PRCF(423,"
SET DA=PRCH
DO ^DIK
KILL DIK
SET DA=""
DO SETR^PRCHCS1
+2 WRITE !,"CODE SHEET DELETED FOR THIS "_$SELECT(PRCHTYP="R":"PARTIAL",1:"ORDER")_" !",$CHAR(7)
KILL PRCHPO
GOTO Q
