| 1 | PRCHCS0 ;WISC/RHD-LOG CODE SHEET EDIT--CALLED FROM PRCHCS ;12/1/93 09:50
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | SC ;MOVES SOURCE CODE TO EACH LINE ITEM IN PO
|
|---|
| 5 | 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)
|
|---|
| 6 | 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)
|
|---|
| 7 | Q
|
|---|
| 8 | HDR I '$D(IOM) D ^%ZISC
|
|---|
| 9 | N J,I,Y F I=1:1:8 S X=I*10-1 I X'>IOM W ?X,I
|
|---|
| 10 | S Y="",$P(Y,"1234567890",9)="" W !,$E(Y,1,IOM)
|
|---|
| 11 | S Y="",$P(Y,"----+----|",9)="" W !,$E(Y,1,IOM) Q
|
|---|
| 12 | 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
|
|---|
| 13 | SIG ; PUT ELEC.SIG.BASED ON P.O.RECORD NO. ONTO P.O.AND SET FLAG TO INDICATE LOG CODE SHEETS WERE GENERATED
|
|---|
| 14 | 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
|
|---|
| 15 | 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
|
|---|
| 16 | 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
|
|---|
| 17 | Q
|
|---|
| 18 | ERR W !?5,"This code sheet is not 80 characters and needs to be edited!",$C(7) Q
|
|---|
| 19 | ERR1 W !?5,"Code sheet for line/item number "_PRCHLI_" has not been completed",!,?5,"and needs to be edited !",$C(7)
|
|---|
| 20 | 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."
|
|---|
| 21 | Q
|
|---|
| 22 | 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
|
|---|
| 23 | 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
|
|---|
| 24 | 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
|
|---|
| 25 | Q
|
|---|
| 26 | Q ;EXIT ROUTINE FOR PRCHCS
|
|---|
| 27 | 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
|
|---|
| 28 | Q
|
|---|
