PRCHCS0 ;WISC/RHD-LOG CODE SHEET EDIT--CALLED FROM PRCHCS ;12/1/93 09:50
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
SC ;MOVES SOURCE CODE TO EACH LINE ITEM IN PO
Q:'$D(PRCHPO) S Y=+$P($G(^PRC(442,PRCHPO,1)),U,7) Q:'$D(^PRCD(420.8,Y,0)) S Y=$P(^(0),U,1)
F I=0:0 S I=$O(^PRC(442,PRCHPO,2,I)) Q:'I S X=$P($G(^(I,2)),U,2),$P(^(4),U,10)=$S(Y'="B":Y,X]"":6,1:2)
Q
HDR I '$D(IOM) D ^%ZISC
N J,I,Y F I=1:1:8 S X=I*10-1 I X'>IOM W ?X,I
S Y="",$P(Y,"1234567890",9)="" W !,$E(Y,1,IOM)
S Y="",$P(Y,"----+----|",9)="" W !,$E(Y,1,IOM) Q
DSP W !! D HDR Q:'$D(^PRCF(423,DA,300)) S X=+^(300),Y=^("CODE",1,0) W !," Line Item: ",X,!,Y D ERR:$L(Y)'=80!($O(^PRCF(423,DA,"CODE",1))) Q
SIG ; PUT ELEC.SIG.BASED ON P.O.RECORD NO. ONTO P.O.AND SET FLAG TO INDICATE LOG CODE SHEETS WERE GENERATED
K PRCHNM S DA=PRCHPO,P=+PRC("PER"),PRCSIG="" D ESIG^PRCUESIG(DUZ,.PRCSIG) S ROUTINE="PRCUESIG" D:PRCSIG'=1 QQ Q:'PRCSIG S PRCHNM=PRCSIG
D NOW^%DTC I PRCHTYP="A" S $P(^PRC(442,PRCHPO,18),U,4)=PRCHKEY,$P(^(18),U,11)="Y",PRCSIG="" K PRCHNM D ENCODE^PRCHES8(DA,DUZ,.PRCSIG) S ROUTINE=$T(+0) D:PRCSIG<1 QQ Q:'PRCSIG K ^PRC(442,"AE","N",PRCHPO) S PRCHNM=PRCSIG Q
I PRCHTYP="R" S $P(^PRC(442,PRCHPO,11,PRCHRPT,1),U,1)=PRCHKEY,$P(^(1),U,6)="Y",PRCSIG="" K PRCHNM D ENCODE^PRCHES3(PRCHPO,PRCHRPT,DUZ,.PRCSIG) S ROUTINE=$T(+0) D:PRCSIG<1 QQ Q:'PRCSIG K ^PRC(442,"AF","N",PRCHPO,PRCHRPT) S PRCHNM=PRCSIG
Q
ERR W !?5,"This code sheet is not 80 characters and needs to be edited!",$C(7) Q
ERR1 W !?5,"Code sheet for line/item number "_PRCHLI_" has not been completed",!,?5,"and needs to be edited !",$C(7)
W !! S %A="Do you want to re-create the code sheet for this line/item ",%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."
Q
ASK W !!?2,"Press RETURN to continue diplaying code sheets or '^' to transmit/edit: " R X:DTIME Q:X="" I X="^" S PRCHLI="z" Q
W !!,"Only an up-arrow or a return are allowed. If you wish to see the rest",!,"of the code sheets online, press return. Otherwise, enter '^'." G ASK
QQ S:'$D(ROUTINE) ROUTINE=$T(+0) W !!,$$ERR^PRCHQQ(ROUTINE,PRCSIG) W:PRCSIG=0!(PRCSIG=-3) !,"Notify Application Coordinator!",$C(7) S DIR(0)="EAO",DIR("A")="Press <return> to continue" D ^DIR K ROUTINE
Q
Q ;EXIT ROUTINE FOR PRCHCS
K %DT,DA,DIC,DIE,DIK,DR,I,J,K,X,Y,Z,PRCFA,PRCH,PRCHAUTO,PRCHBTYP,PRCHLI,PRCFASYS,PRCFCS,PRCH0,PRCH2,PRCH4,PRCHCOM,PRCHI,PRCHI0,PRCHIV0,PRCHLCNT,PRCHOK,PRCHQTY,PRCHR0,PRCHRRI,PRCHSRC,ROUTINE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHCS0 2573 printed Sep 23, 2025@19:42:21 Page 2
PRCHCS0 ;WISC/RHD-LOG CODE SHEET EDIT--CALLED FROM PRCHCS ;12/1/93 09:50
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
SC ;MOVES SOURCE CODE TO EACH LINE ITEM IN PO
+1 if '$DATA(PRCHPO)
QUIT
SET Y=+$PIECE($GET(^PRC(442,PRCHPO,1)),U,7)
if '$DATA(^PRCD(420.8,Y,0))
QUIT
SET Y=$PIECE(^(0),U,1)
+2 FOR I=0:0
SET I=$ORDER(^PRC(442,PRCHPO,2,I))
if 'I
QUIT
SET X=$PIECE($GET(^(I,2)),U,2)
SET $PIECE(^(4),U,10)=$SELECT(Y'="B":Y,X]"":6,1:2)
+3 QUIT
HDR IF '$DATA(IOM)
DO ^%ZISC
+1 NEW J,I,Y
FOR I=1:1:8
SET X=I*10-1
IF X'>IOM
WRITE ?X,I
+2 SET Y=""
SET $PIECE(Y,"1234567890",9)=""
WRITE !,$EXTRACT(Y,1,IOM)
+3 SET Y=""
SET $PIECE(Y,"----+----|",9)=""
WRITE !,$EXTRACT(Y,1,IOM)
QUIT
DSP WRITE !!
DO HDR
if '$DATA(^PRCF(423,DA,300))
QUIT
SET X=+^(300)
SET Y=^("CODE",1,0)
WRITE !," Line Item: ",X,!,Y
if $LENGTH(Y)'=80!($ORDER(^PRCF(423,DA,"CODE",1)))
DO ERR
QUIT
SIG ; PUT ELEC.SIG.BASED ON P.O.RECORD NO. ONTO P.O.AND SET FLAG TO INDICATE LOG CODE SHEETS WERE GENERATED
+1 KILL PRCHNM
SET DA=PRCHPO
SET P=+PRC("PER")
SET PRCSIG=""
DO ESIG^PRCUESIG(DUZ,.PRCSIG)
SET ROUTINE="PRCUESIG"
if PRCSIG'=1
DO QQ
if 'PRCSIG
QUIT
SET PRCHNM=PRCSIG
+2 DO NOW^%DTC
IF PRCHTYP="A"
SET $PIECE(^PRC(442,PRCHPO,18),U,4)=PRCHKEY
SET $PIECE(^(18),U,11)="Y"
SET PRCSIG=""
KILL PRCHNM
DO ENCODE^PRCHES8(DA,DUZ,.PRCSIG)
SET ROUTINE=$TEXT(+0)
if PRCSIG<1
DO QQ
if 'PRCSIG
QUIT
KILL ^PRC(442,"AE","N",PRCHPO)
SET PRCHNM=PRCSIG
QUIT
+3 IF PRCHTYP="R"
SET $PIECE(^PRC(442,PRCHPO,11,PRCHRPT,1),U,1)=PRCHKEY
SET $PIECE(^(1),U,6)="Y"
SET PRCSIG=""
KILL PRCHNM
DO ENCODE^PRCHES3(PRCHPO,PRCHRPT,DUZ,.PRCSIG)
SET ROUTINE=$TEXT(+0)
if PRCSIG<1
DO QQ
if 'PRCSIG
QUIT
KILL ^PRC(442,"AF","N",PRCHPO,PRCHRPT)
SET PRCHNM=PRCSIG
+4 QUIT
ERR WRITE !?5,"This code sheet is not 80 characters and needs to be edited!",$CHAR(7)
QUIT
ERR1 WRITE !?5,"Code sheet for line/item number "_PRCHLI_" has not been completed",!,?5,"and needs to be edited !",$CHAR(7)
+1 WRITE !!
SET %A="Do you want to re-create the code sheet for this line/item "
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."
+2 QUIT
ASK WRITE !!?2,"Press RETURN to continue diplaying code sheets or '^' to transmit/edit: "
READ X:DTIME
if X=""
QUIT
IF X="^"
SET PRCHLI="z"
QUIT
+1 WRITE !!,"Only an up-arrow or a return are allowed. If you wish to see the rest",!,"of the code sheets online, press return. Otherwise, enter '^'."
GOTO ASK
QQ if '$DATA(ROUTINE)
SET ROUTINE=$TEXT(+0)
WRITE !!,$$ERR^PRCHQQ(ROUTINE,PRCSIG)
if PRCSIG=0!(PRCSIG=-3)
WRITE !,"Notify Application Coordinator!",$CHAR(7)
SET DIR(0)="EAO"
SET DIR("A")="Press <return> to continue"
DO ^DIR
KILL ROUTINE
+1 QUIT
Q ;EXIT ROUTINE FOR PRCHCS
+1 KILL %DT,DA,DIC,DIE,DIK,DR,I,J,K,X,Y,Z,PRCFA,PRCH,PRCHAUTO,PRCHBTYP,PRCHLI,PRCFASYS,PRCFCS,PRCH0,PRCH2,PRCH4,PRCHCOM,PRCHI,PRCHI0,PRCHIV0,PRCHLCNT,PRCHOK,PRCHQTY,PRCHR0,PRCHRRI,PRCHSRC,ROUTINE
+2 QUIT
