PRCHCS3 ;WISC/RHD-EDIT LOG CODE SHEETS ;9/16/94 12:23 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
EN S PRCFA("SYS")="LOG",PRCFA("REF")="",PRCHAUTO="" W !," Now creating LOG code sheets ."
S PRCHLI=0,PRCHLCNT=0 F PRCHI=1:1 S PRCHLI=$O(^PRCS(410,PRCHR,"IT",PRCHLI)) Q:'PRCHLI D SET S:$D(DA) PRCHLCNT=PRCHLCNT+1 I '$D(DA) D ^PRCHCS5 Q:'$D(PRCFA) W "." I $D(DA),DA S PRCHLCNT=PRCHLCNT+1
I PRCHLCNT'>0 W !,"No code sheets created !",$C(7) K PRCHR G Q
1 D:'$D(IOF) HOME^%ZIS W !! D HDR^PRCHCS0
S PRCHLI=0 F PRCHI=1:1 S PRCHLI=$O(^PRCS(410,PRCHR,"IT",PRCHLI)) Q:'PRCHLI S PRCH="" D CHK S:$D(DA) PRCH=DA D:'PRCH ERR1 D:PRCH 11
G 2
11 I '$D(^PRCF(423,PRCH,300))!('$D(^("CODE",1,0))) D ERR1 Q
S X=+^PRCF(423,PRCH,300),Y=^("CODE",1,0) W !," Line Item: ",X,!,Y D ERR^PRCHCS0:$L(Y)'=80!($O(^PRCF(423,PRCH,"CODE",1))),ASK^PRCHCS0:'(PRCHLI#9)
Q
2 G:'PRCH DEL G:$L(Y)'=80!($O(^PRCF(423,PRCH,"CODE",1))) 3
W ! S %A="Do you want to transmit these code sheets",%B="'YES' will mark the code sheets for transmission.",%B(1)="'NO' will give you a chance to edit code sheets."
S %B(2)="'^' will delete code sheets." D ^PRCFYN G TRAN:%=1,DEL1:%<0
3 S %A="Do you want to edit any code sheets",%B="'YES' to edit any code sheet.",%B(1)="'NO' or '^' for chance to delete code sheets." D ^PRCFYN G DEL:%'=1
4 D LI G:Y<0 2 K PRCHLOG S DIE="^PRCF(423,",DR=PRCFA("EDIT") D ^DIE S PRCHLOG=1 D ^PRCFACX1,DSP^PRCHCS0
G 4
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^PRCHCS4 I PRCSIG'=1 D:$D(PRCHLOG) DEL1 K PRCHR G Q
S PRCHLI=0 F PRCHI=1:1 S PRCHLI=$O(^PRCS(410,PRCHR,"IT",PRCHLI)) Q:'PRCHLI D CHK I $D(DA) S PRCSIG="" D G:PRCSIG<1 QQ S DIE="^PRCF(423,",DR="999////"_+PRC("PER")_";.5///"_PRCHDT_";.6///5;.8///3;300.1///"_PRCHKEY D ^DIE
.D ENCODE^PRCFES1(DA,DUZ,.PRCSIG) S ROUTINE=$T(+0)
S DA=PRCHR I $D(^PRC(443,DA,0)) S DIK="^PRC(443," D ^DIK K DIK
W !!,$C(7),"CODE SHEETS MARKED FOR TRANSMISSION!" G Q
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 G Q^PRCHCS4
SET ;S PRCH0=^PRCS(410,PRCHR,"IT",PRCHLI,0),I=+$P(^(0),U,5),PRCH2=$S($D(^(100)):^(100),1:""),PRCHI0=$S($D(^PRC(441,I,0)):^(0),1:""),PRCHIV0=$S($D(^PRC(441,I,2,+^PRCS(410,PRCHR,2),0)):^(0),1:"")
S PRCH0=^PRCS(410,PRCHR,"IT",PRCHLI,0),I=+$P(^(0),U,5),PRCH2=$G(^(100)),PRCHI0=$G(^PRC(441,I,0)),PRCHIV0=$G(^PRC(441,I,2,+^PRCS(410,PRCHR,2),0))
CHK ;SEE WHETHER CODE SHEET ALREADY ON FILE
S DA=$P($G(^PRCS(410,PRCHR,"IT",PRCHLI,0)),U,9) I $D(DA),$D(^PRCF(423,+DA,0)) Q
K DA
Q
ERR1 W !?5,"Code sheet for line/item number "_PRCHLI_" has not been completed",!,"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 Issue Request data as it was before",%B(1)="editing. Any other answer will do nothing." D ^PRCFYN Q:%'=1
D SET,^PRCHCS5 Q:'$D(PRCFA) I $D(DA),DA S PRCH=DA
Q
LI K DA,DIC,PRCHDA S D0=PRCHR,DIC="^PRCS(410,PRCHR,""IT"",",DIC(0)="AEMQ" S DIC("S")="I $D(^(0)) S PRCHDA=$P(^(0),U,9) I PRCHDA"
D ^DIC K DIC Q:Y<0 S PRCHLI=+Y S:$D(PRCHDA) DA=PRCHDA K PRCHDA
Q
DEL S %A="Delete all code sheets for this Issue Request",%B="'YES' or '^' to delete all code sheets.",%B(1)="'NO' to delete selected Line Item code sheets." D ^PRCFYN G:%'=2 DEL1
DEL0 W !?3,"Delete selected Line Item Code Sheets:" D LI G:'$D(DA) 1 S DIK="^PRCF(423," D ^DIK S DA="" D SETR^PRCHCS5 G DEL0
DEL1 ;DELETES ALL CODE SHEETS
S DIK="^PRCF(423," D WAIT^DICD
S PRCHLI=0 F PRCHI=1:1 S PRCHLI=$O(^PRCS(410,PRCHR,"IT",PRCHLI)) Q:'PRCHLI D CHK I $D(DA) D ^DIK S DA="" D SETR^PRCHCS5
K DIK W !,"ALL CODE SHEETS DELETED FOR THIS ISSUE REQUEST!",$C(7) K PRCHR G Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHCS3 3942 printed Apr 09, 2024@21:18:16 Page 2
PRCHCS3 ;WISC/RHD-EDIT LOG CODE SHEETS ;9/16/94 12:23 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN SET PRCFA("SYS")="LOG"
SET PRCFA("REF")=""
SET PRCHAUTO=""
WRITE !," Now creating LOG code sheets ."
+1 SET PRCHLI=0
SET PRCHLCNT=0
FOR PRCHI=1:1
SET PRCHLI=$ORDER(^PRCS(410,PRCHR,"IT",PRCHLI))
if 'PRCHLI
QUIT
DO SET
if $DATA(DA)
SET PRCHLCNT=PRCHLCNT+1
IF '$DATA(DA)
DO ^PRCHCS5
if '$DATA(PRCFA)
QUIT
WRITE "."
IF $DATA(DA)
IF DA
SET PRCHLCNT=PRCHLCNT+1
+2 IF PRCHLCNT'>0
WRITE !,"No code sheets created !",$CHAR(7)
KILL PRCHR
GOTO Q
1 if '$DATA(IOF)
DO HOME^%ZIS
WRITE !!
DO HDR^PRCHCS0
+1 SET PRCHLI=0
FOR PRCHI=1:1
SET PRCHLI=$ORDER(^PRCS(410,PRCHR,"IT",PRCHLI))
if 'PRCHLI
QUIT
SET PRCH=""
DO CHK
if $DATA(DA)
SET PRCH=DA
if 'PRCH
DO ERR1
if PRCH
DO 11
+2 GOTO 2
11 IF '$DATA(^PRCF(423,PRCH,300))!('$DATA(^("CODE",1,0)))
DO ERR1
QUIT
+1 SET X=+^PRCF(423,PRCH,300)
SET Y=^("CODE",1,0)
WRITE !," Line Item: ",X,!,Y
if $LENGTH(Y)'=80!($ORDER(^PRCF(423,PRCH,"CODE",1)))
DO ERR^PRCHCS0
if '(PRCHLI#9)
DO ASK^PRCHCS0
+2 QUIT
2 if 'PRCH
GOTO DEL
if $LENGTH(Y)'=80!($ORDER(^PRCF(423,PRCH,"CODE",1)))
GOTO 3
+1 WRITE !
SET %A="Do you want to transmit these code sheets"
SET %B="'YES' will mark the code sheets for transmission."
SET %B(1)="'NO' will give you a chance to edit code sheets."
+2 SET %B(2)="'^' will delete code sheets."
DO ^PRCFYN
if %=1
GOTO TRAN
if %<0
GOTO DEL1
3 SET %A="Do you want to edit any code sheets"
SET %B="'YES' to edit any code sheet."
SET %B(1)="'NO' or '^' for chance to delete code sheets."
DO ^PRCFYN
if %'=1
GOTO DEL
4 DO LI
if Y<0
GOTO 2
KILL PRCHLOG
SET DIE="^PRCF(423,"
SET DR=PRCFA("EDIT")
DO ^DIE
SET PRCHLOG=1
DO ^PRCFACX1
DO DSP^PRCHCS0
+1 GOTO 4
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^PRCHCS4
IF PRCSIG'=1
if $DATA(PRCHLOG)
DO DEL1
KILL PRCHR
GOTO Q
+3 SET PRCHLI=0
FOR PRCHI=1:1
SET PRCHLI=$ORDER(^PRCS(410,PRCHR,"IT",PRCHLI))
if 'PRCHLI
QUIT
DO CHK
IF $DATA(DA)
SET PRCSIG=""
Begin DoDot:1
+4 DO ENCODE^PRCFES1(DA,DUZ,.PRCSIG)
SET ROUTINE=$TEXT(+0)
End DoDot:1
if PRCSIG<1
GOTO QQ
SET DIE="^PRCF(423,"
SET DR="999////"_+PRC("PER")_";.5///"_PRCHDT_";.6///5;.8///3;300.1///"_PRCHKEY
DO ^DIE
+5 SET DA=PRCHR
IF $DATA(^PRC(443,DA,0))
SET DIK="^PRC(443,"
DO ^DIK
KILL DIK
+6 WRITE !!,$CHAR(7),"CODE SHEETS MARKED FOR TRANSMISSION!"
GOTO Q
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
Q GOTO Q^PRCHCS4
SET ;S PRCH0=^PRCS(410,PRCHR,"IT",PRCHLI,0),I=+$P(^(0),U,5),PRCH2=$S($D(^(100)):^(100),1:""),PRCHI0=$S($D(^PRC(441,I,0)):^(0),1:""),PRCHIV0=$S($D(^PRC(441,I,2,+^PRCS(410,PRCHR,2),0)):^(0),1:"")
+1 SET PRCH0=^PRCS(410,PRCHR,"IT",PRCHLI,0)
SET I=+$PIECE(^(0),U,5)
SET PRCH2=$GET(^(100))
SET PRCHI0=$GET(^PRC(441,I,0))
SET PRCHIV0=$GET(^PRC(441,I,2,+^PRCS(410,PRCHR,2),0))
CHK ;SEE WHETHER CODE SHEET ALREADY ON FILE
+1 SET DA=$PIECE($GET(^PRCS(410,PRCHR,"IT",PRCHLI,0)),U,9)
IF $DATA(DA)
IF $DATA(^PRCF(423,+DA,0))
QUIT
+2 KILL DA
+3 QUIT
ERR1 WRITE !?5,"Code sheet for line/item number "_PRCHLI_" has not been completed",!,"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 Issue Request data as it was before"
SET %B(1)="editing. Any other answer will do nothing."
DO ^PRCFYN
if %'=1
QUIT
+2 DO SET
DO ^PRCHCS5
if '$DATA(PRCFA)
QUIT
IF $DATA(DA)
IF DA
SET PRCH=DA
+3 QUIT
LI KILL DA,DIC,PRCHDA
SET D0=PRCHR
SET DIC="^PRCS(410,PRCHR,""IT"","
SET DIC(0)="AEMQ"
SET DIC("S")="I $D(^(0)) S PRCHDA=$P(^(0),U,9) I PRCHDA"
+1 DO ^DIC
KILL DIC
if Y<0
QUIT
SET PRCHLI=+Y
if $DATA(PRCHDA)
SET DA=PRCHDA
KILL PRCHDA
+2 QUIT
DEL SET %A="Delete all code sheets for this Issue Request"
SET %B="'YES' or '^' to delete all code sheets."
SET %B(1)="'NO' to delete selected Line Item code sheets."
DO ^PRCFYN
if %'=2
GOTO DEL1
DEL0 WRITE !?3,"Delete selected Line Item Code Sheets:"
DO LI
if '$DATA(DA)
GOTO 1
SET DIK="^PRCF(423,"
DO ^DIK
SET DA=""
DO SETR^PRCHCS5
GOTO DEL0
DEL1 ;DELETES ALL CODE SHEETS
+1 SET DIK="^PRCF(423,"
DO WAIT^DICD
+2 SET PRCHLI=0
FOR PRCHI=1:1
SET PRCHLI=$ORDER(^PRCS(410,PRCHR,"IT",PRCHLI))
if 'PRCHLI
QUIT
DO CHK
IF $DATA(DA)
DO ^DIK
SET DA=""
DO SETR^PRCHCS5
+3 KILL DIK
WRITE !,"ALL CODE SHEETS DELETED FOR THIS ISSUE REQUEST!",$CHAR(7)
KILL PRCHR
GOTO Q
