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