- 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 Mar 13, 2025@21:11:12 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
