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