- PRCHDEP2 ;WISC/RWS-EDIT DEPOT LOG CODE SHEETS ;9/16/94 12:24 PM
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- EN S PRCHN("PO")=$P($P(^PRC(442,PRCHPO,0),"-",2),U,1),PRCFA("SYS")="LOG",PRCFA("REF")=PRCHN("PO"),PRCHAUTO="" W !," Now creating LOG code sheets ."
- S PRCHLI=0,PRCHLCNT=0 F PRCHI=1:1 S PRCHLI=$O(^PRC(442,PRCHPO,2,PRCHLI)) Q:'PRCHLI D SET I PRCHOK S:$D(DA) PRCHLCNT=PRCHLCNT+1 I '$D(DA) D ^PRCHCS1 Q:'$D(PRCFA) W "." I $D(DA),DA S PRCHLCNT=PRCHLCNT+1
- I PRCHLCNT'>0 W !,"No code sheets created !",$C(7) K PRCHPO G Q
- ;
- 1 S PRCHLCNT=0,PRCFA("SYS")="LOG" D:'$D(IOF) HOME^%ZIS W !! D HDR^PRCHCS0
- S PRCHLI=0 F PRCHI=1:1 S PRCHLI=$O(^PRC(442,PRCHPO,2,PRCHLI)) S PRCHLCNT=PRCHLCNT+1 Q:'PRCHLI S PRCH="" D CHK I PRCHOK S:$D(DA) PRCH=DA 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 W ! S %A="Do you want to mark these code sheets for transmission",%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,UNLCK^PRCHDEP3
- 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^PRCHCS0 I '$D(PRCHNM) D:$D(PRCHLOG) DEL1 K PRCHPO G Q
- S PRCHLI=0,PRCHBTYP=5 S:PRCFA("TT")=100 PRCHBTYP=7 F PRCHI=1:1 S PRCHLI=$O(^PRC(442,PRCHPO,2,PRCHLI)) Q:'PRCHLI D CHK I PRCHOK,$D(DA) D MRK
- W !!,$C(7),"CODE SHEETS MARKED FOR TRANSMISSION!"
- D UNLCK1^PRCHDEP3
- S DIC="^PRC(442,",DA=PRCHPO D UNLCK^PRCHDEP3
- 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 D Q^PRCHCS0 K ROUTINE Q
- ;
- MRK ;MARK CODE SHEET FOR TRANSMISSION
- S PRCSIG="" D ENCODE^PRCFES1(DA,DUZ,.PRCSIG) S ROUTINE=$T(+0) G:PRCSIG<1 QQ S DIE="^PRCF(423,",DR="999////"_+PRC("PER")_";.5///"_PRCHDT_";.6///"_PRCHBTYP_";.8///3;300.1///"_PRCHKEY D ^DIE Q
- ;
- SET S PRCH0=^PRC(442,PRCHPO,2,PRCHLI,0),I=+$P(^(0),U,5),PRCH2=$G(^(2)),PRCH4=$G(^(4)),PRCHI0=$G(^PRC(441,I,0)),PRCHIV0=$G(^PRC(441,I,2,+^PRC(442,PRCHPO,1),0))
- I PRCHI0="" S PRCHI0=$O(^PRC(442,PRCHPO,2,PRCHLI,1,0)) I $D(^(+PRCHI0,0)) S PRCHI0="^"_$E(^(0),1,60)
- CHK ;SEE WHETHER CODE SHEET ALREADY ON FILE
- S PRCHOK=0 K DA I PRCHTYP="R" S PRCHRRI=$O(^PRC(442,PRCHPO,2,"AB",PRCHRD,PRCHLI,0)) Q:'PRCHRRI S PRCHR0=$G(^PRC(442,PRCHPO,2,PRCHLI,3,PRCHRRI,0)) I PRCHR0=""!('$P(PRCHR0,U,2)) Q
- S PRCHOK=1 I PRCHTYP="R" S DA=$P($G(^PRC(442,PRCHPO,2,PRCHLI,3,PRCHRRI,0)),U,6)
- I PRCHTYP="A" S DA=$P($G(^PRC(442,PRCHPO,2,PRCHLI,4)),U,8)
- I $D(DA),$D(^PRCF(423,+DA,0)) Q
- K DA
- Q
- ;
- ERR1 D ERR1^PRCHCS0,^PRCFYN Q:%'=1
- S DR=PRCFA("EDIT"),DA=PRCH,DIE="^PRCF(423," D ^DIE Q:'$D(PRCFA) I $D(DA),DA S PRCH=DA
- Q
- ;
- LI K DA,DIC,PRCHDA S D0=PRCHPO,DIC="^PRC(442,PRCHPO,2,",DIC(0)="AEMQ" S:PRCHTYP="A" DIC("S")="I $D(^(4)) S PRCHDA=$P(^(4),U,8) I PRCHDA"
- S:PRCHTYP="R" DIC("S")="S PRCHRRI=$O(^PRC(442,PRCHPO,2,""AB"",PRCHRD,Y,0)) I $D(^PRC(442,PRCHPO,2,Y,3,+PRCHRRI,0)) S PRCHDA=$P(^(0),U,6) 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 "_$S(PRCHTYP="R":"Partial",1:"Order"),%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 K ^PRCF(423,DA,"CODE") S DA="" D SETR^PRCHCS1 G DEL0
- ;
- DEL1 ;DELETES ALL CODE SHEETS
- S PRCHLI=0 F PRCHI=1:1 S PRCHLI=$O(^PRC(442,PRCHPO,2,PRCHLI)) Q:'PRCHLI D CHK I $D(DA) K ^PRCF(423,DA,"CODE")
- K ^PRC(442,"AF","N",PRCHPO,PRCHRRI) W !,"ALL CODE SHEETS DELETED FOR THIS "_$S(PRCHTYP="R":"PARTIAL",1:"ORDER")_" !",$C(7) K PRCHPO G Q
- CS S PRCFA("TTLEN")=80,PRCHAUTO="" D NEWCS^PRCFAC S PRCH=DA G 11
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHDEP2 4380 printed Jan 18, 2025@03:07:47 Page 2
- PRCHDEP2 ;WISC/RWS-EDIT DEPOT LOG CODE SHEETS ;9/16/94 12:24 PM
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- EN SET PRCHN("PO")=$PIECE($PIECE(^PRC(442,PRCHPO,0),"-",2),U,1)
- SET PRCFA("SYS")="LOG"
- SET PRCFA("REF")=PRCHN("PO")
- SET PRCHAUTO=""
- WRITE !," Now creating LOG code sheets ."
- +1 SET PRCHLI=0
- SET PRCHLCNT=0
- FOR PRCHI=1:1
- SET PRCHLI=$ORDER(^PRC(442,PRCHPO,2,PRCHLI))
- if 'PRCHLI
- QUIT
- DO SET
- IF PRCHOK
- if $DATA(DA)
- SET PRCHLCNT=PRCHLCNT+1
- IF '$DATA(DA)
- DO ^PRCHCS1
- 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 PRCHPO
- GOTO Q
- +3 ;
- 1 SET PRCHLCNT=0
- SET PRCFA("SYS")="LOG"
- if '$DATA(IOF)
- DO HOME^%ZIS
- WRITE !!
- DO HDR^PRCHCS0
- +1 SET PRCHLI=0
- FOR PRCHI=1:1
- SET PRCHLI=$ORDER(^PRC(442,PRCHPO,2,PRCHLI))
- SET PRCHLCNT=PRCHLCNT+1
- if 'PRCHLI
- QUIT
- SET PRCH=""
- DO CHK
- IF PRCHOK
- if $DATA(DA)
- SET PRCH=DA
- if PRCH
- DO 11
- +2 GOTO 2
- +3 ;
- 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
- +3 ;
- 2 WRITE !
- SET %A="Do you want to mark these code sheets for transmission"
- SET %B="'YES' will mark the code sheets for transmission."
- SET %B(1)="'NO' will give you a chance to edit code sheets."
- +1 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
- DO UNLCK^PRCHDEP3
- +1 GOTO 4
- +2 ;
- 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^PRCHCS0
- IF '$DATA(PRCHNM)
- if $DATA(PRCHLOG)
- DO DEL1
- KILL PRCHPO
- GOTO Q
- +3 SET PRCHLI=0
- SET PRCHBTYP=5
- if PRCFA("TT")=100
- SET PRCHBTYP=7
- FOR PRCHI=1:1
- SET PRCHLI=$ORDER(^PRC(442,PRCHPO,2,PRCHLI))
- if 'PRCHLI
- QUIT
- DO CHK
- IF PRCHOK
- IF $DATA(DA)
- DO MRK
- +4 WRITE !!,$CHAR(7),"CODE SHEETS MARKED FOR TRANSMISSION!"
- +5 DO UNLCK1^PRCHDEP3
- +6 SET DIC="^PRC(442,"
- SET DA=PRCHPO
- DO UNLCK^PRCHDEP3
- +7 GOTO Q
- +8 ;
- 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 ;
- Q DO Q^PRCHCS0
- KILL ROUTINE
- QUIT
- +1 ;
- MRK ;MARK CODE SHEET FOR TRANSMISSION
- +1 SET PRCSIG=""
- DO ENCODE^PRCFES1(DA,DUZ,.PRCSIG)
- SET ROUTINE=$TEXT(+0)
- if PRCSIG<1
- GOTO QQ
- SET DIE="^PRCF(423,"
- SET DR="999////"_+PRC("PER")_";.5///"_PRCHDT_";.6///"_PRCHBTYP_";.8///3;300.1///"_PRCHKEY
- DO ^DIE
- QUIT
- +2 ;
- SET SET PRCH0=^PRC(442,PRCHPO,2,PRCHLI,0)
- SET I=+$PIECE(^(0),U,5)
- SET PRCH2=$GET(^(2))
- SET PRCH4=$GET(^(4))
- SET PRCHI0=$GET(^PRC(441,I,0))
- SET PRCHIV0=$GET(^PRC(441,I,2,+^PRC(442,PRCHPO,1),0))
- +1 IF PRCHI0=""
- SET PRCHI0=$ORDER(^PRC(442,PRCHPO,2,PRCHLI,1,0))
- IF $DATA(^(+PRCHI0,0))
- SET PRCHI0="^"_$EXTRACT(^(0),1,60)
- CHK ;SEE WHETHER CODE SHEET ALREADY ON FILE
- +1 SET PRCHOK=0
- KILL DA
- IF PRCHTYP="R"
- SET PRCHRRI=$ORDER(^PRC(442,PRCHPO,2,"AB",PRCHRD,PRCHLI,0))
- if 'PRCHRRI
- QUIT
- SET PRCHR0=$GET(^PRC(442,PRCHPO,2,PRCHLI,3,PRCHRRI,0))
- IF PRCHR0=""!('$PIECE(PRCHR0,U,2))
- QUIT
- +2 SET PRCHOK=1
- IF PRCHTYP="R"
- SET DA=$PIECE($GET(^PRC(442,PRCHPO,2,PRCHLI,3,PRCHRRI,0)),U,6)
- +3 IF PRCHTYP="A"
- SET DA=$PIECE($GET(^PRC(442,PRCHPO,2,PRCHLI,4)),U,8)
- +4 IF $DATA(DA)
- IF $DATA(^PRCF(423,+DA,0))
- QUIT
- +5 KILL DA
- +6 QUIT
- +7 ;
- ERR1 DO ERR1^PRCHCS0
- DO ^PRCFYN
- if %'=1
- QUIT
- +1 SET DR=PRCFA("EDIT")
- SET DA=PRCH
- SET DIE="^PRCF(423,"
- DO ^DIE
- if '$DATA(PRCFA)
- QUIT
- IF $DATA(DA)
- IF DA
- SET PRCH=DA
- +2 QUIT
- +3 ;
- LI KILL DA,DIC,PRCHDA
- SET D0=PRCHPO
- SET DIC="^PRC(442,PRCHPO,2,"
- SET DIC(0)="AEMQ"
- if PRCHTYP="A"
- SET DIC("S")="I $D(^(4)) S PRCHDA=$P(^(4),U,8) I PRCHDA"
- +1 if PRCHTYP="R"
- SET DIC("S")="S PRCHRRI=$O(^PRC(442,PRCHPO,2,""AB"",PRCHRD,Y,0)) I $D(^PRC(442,PRCHPO,2,Y,3,+PRCHRRI,0)) S PRCHDA=$P(^(0),U,6) I PRCHDA"
- +2 DO ^DIC
- KILL DIC
- if Y<0
- QUIT
- SET PRCHLI=+Y
- if $DATA(PRCHDA)
- SET DA=PRCHDA
- KILL PRCHDA
- +3 QUIT
- +4 ;
- DEL SET %A="Delete all code sheets for this "_$SELECT(PRCHTYP="R":"Partial",1:"Order")
- 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
- KILL ^PRCF(423,DA,"CODE")
- SET DA=""
- DO SETR^PRCHCS1
- GOTO DEL0
- +1 ;
- DEL1 ;DELETES ALL CODE SHEETS
- +1 SET PRCHLI=0
- FOR PRCHI=1:1
- SET PRCHLI=$ORDER(^PRC(442,PRCHPO,2,PRCHLI))
- if 'PRCHLI
- QUIT
- DO CHK
- IF $DATA(DA)
- KILL ^PRCF(423,DA,"CODE")
- +2 KILL ^PRC(442,"AF","N",PRCHPO,PRCHRRI)
- WRITE !,"ALL CODE SHEETS DELETED FOR THIS "_$SELECT(PRCHTYP="R":"PARTIAL",1:"ORDER")_" !",$CHAR(7)
- KILL PRCHPO
- GOTO Q
- CS SET PRCFA("TTLEN")=80
- SET PRCHAUTO=""
- DO NEWCS^PRCFAC
- SET PRCH=DA
- GOTO 11