PRCHEC ;SF-ISC/TKW-EDIT FOR SUPPLY SYSTEM--LOG CODE SHEETS ; 5/17/00 4:05pm
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
EN1 ;CREATE ACQUISITIONS LOG CODE SHEETS, UPDATE OBLIGATED BALANCE (IF SUPPLY FUND P.O.)
D ST G:'$D(PRC("SITE")) Q D ASK^PRCHEC1 G:%=-1 Q I %=1 S PRCHQ="EN1" D EN^PRCHRCS
EN01 Q:'$D(PRC("SITE")) G:$D(PRCHENT) Q2 S PRCHP("S")="$D(^PRC(442,""AE"",""N"",+Y))" D PO G:'$D(PRCHPO) Q
I '$D(PRCHENT) D LCK1 G:'$D(DA) EN01
I $D(^PRC(442,PRCHPO,1)),"013"[$P(^(1),U,7) S PRCHNRQ=1
S %=1,%B="",%A=" Review Order " D ^PRCFYN G:%=-1 Q I %=1 S D0=PRCHPO D ^PRCHDP1
;
EN11 ;ENTRY POINT IF CALLED WHEN REQUISITION SIGNED.
S TAGLCK="EN01"
D SETUP^PRCHEC1,CAL2^PRCHEC2
I PRCHN("SFC")=2,PRCHN("MP")'=12,'$D(PRCHNRQ) D OBL^PRCHEC1 G:'$D(PRCHPO) Q I $P(^PRC(442,PRCHPO,0),U,2)=3 S X=40,DA=PRCHPO D ENS^PRCHSTAT
I $D(^PRC(442,PRCHPO,18)),$P(^(18),U,6)]"" D ERR G:'$D(PRCHENT) UNLCK G EN01
I $D(PRCHENT) D LCK1 G:'$D(DA) EN01 ;CALL FROM PRCHNRQ ROUTINE.
S PRCHTYP="A" D EDIT^PRCHEC1 G:'$D(PRCHPO) UNLCK S PRCHKEY=PRCHPONO W !!!
I PRCHN("SFC")'=2&("013"'[(PRCHN("SC"))) W $C(7),!,"NOT POSTED STOCK AND NOT A REQUISITION--ACQUISITION CODE SHEETS ARE",!,"NOT REQUIRED!!" G UNLCK
I $D(PRCHNRQ),PRCHN("SFC")=2 S PRCFA("DICS")=$S(PRCHN("SC")=0:"I Y=100",PRCHN("SC")=1:"I Y=500!(Y=504)",PRCHN("SC")=3:"I Y=630",1:"I Y=630")
I $D(PRCHNRQ),PRCHN("SFC")'=2 S PRCFA("DICS")=$S(PRCHN("SC")=0:"I Y=100",PRCHN("SC")=1:"I Y=501!(Y=505)!(Y=510)!(Y=514)!(Y=515)",1:"I Y=700")
I '$D(PRCHNRQ) S PRCFA("DICS")="I Y=630"
S PRCFA("TT")=+$P(PRCFA("DICS"),"=",2)
I '$D(PRCHISMS) D GT G:'% UNLCK
S Y=PRCFA("TT"),X=$S(Y=100:"B100",Y=700:"B700","501.505.510.514.515"[Y:"B501",1:"B500"),X=X_"^PRCHCS2" D @X
D SC^PRCHCS0,^PRCHCS G UNLCK
;
EN2 ;CREATE LOG RECEIPT CODE SHEETS
D ST G:'$D(PRC("SITE")) Q D ASK^PRCHEC1 G:%=-1 Q I %=1 S PRCHQ="EN2" D EN^PRCHRCS
;
EN20 Q:'$D(PRC("SITE")) S PRCHP("S")="$D(^PRC(442,""AF"",""N"",+Y))"
S TAGLCK="EN20" D PO G:'$D(PRCHPO) Q I X<25!(X>44) W $C(7)," ??" G EN20
D LCK1 G:'$D(DA) EN20
I '$O(^PRC(442,PRCHPO,11,0)) W !?3,"P.O. has no Receiving Reports !",$C(7) G UNLCK
S DIC="^PRC(442,PRCHPO,11,",DIC(0)="QEANZ" D ^DIC K DIC
I Y<0 G UNLCK
S (PRCHRPT,PRCHDPT)=+Y I '$D(Y(0)) G UNLCK
S (PRCHRD,PRCHDRD)=$P(Y(0),U,1),PRCHCMI=$S($P(Y(0),U,9)="":"P",1:"")
I $D(^PRC(442,PRCHPO,11,PRCHRPT,1)),$P(^(1),U,4)]"" D ERR G UNLCK
D SETUP^PRCHEC1,CALTOT^PRCHEC2 S PRCHTYP="R" D EDIT^PRCHEC1
I '$D(PRCHPO) G UNLCK
S PRCHKEY=PRCHPONO_"."_PRCHRPT
S PRCHDIET=$P($G(^PRC(442,PRCHPO,11,PRCHRPT,1)),U,2),PRCHDTP=1
W !!! S %A="DISPLAY RECEIVING REPORT ONLINE ",%=2 D ^PRCFYN
I %=-1 G UNLCK
I %=1 D ^PRCHDP3
W !!!
S PRCFA("DICS")=$S(PRCHN("SC")=1&(PRCHN("SFC")=2):"I Y=551",PRCHN("SC")=1:"I Y=552",PRCHN("SFC")=2:"I Y=632!(Y=633)",1:"I Y=710!(Y=711)")
S PRCFA("TT")=+$P(PRCFA("DICS"),"=",2),PRCHN("FMO")=$E("1234567890JK",+$E(PRCHRD,4,5))
D GT G:'% UNLCK
S Y=PRCFA("TT"),X=$S(Y=551:"B551",Y=552:"B552",Y=710:"B710",1:"B632"),X=X_"^PRCHCS7" D @X
I PRCFA("TT")["55" D
. D ^PRCHCS8
E D
. D SC^PRCHCS0,^PRCHCS
G UNLCK
;
Q K PRC,PRCHPO,PRCHN,PRCHNM,PRCHNRQ,TAGLCK
;
Q2 K PRCF,PRCFA,PRCFASYS,PRCHCS,PRCHTP,PRCHAMT,PRCHCNT,PRCHENT,PRCHRPT,PRCHRD,PRCHCMI,PRCHEMG,PRCHEST,PRCHFA,PRCHLOG,PRCHDIET,PRCHDPT,PRCHDRD,PRCHDT,PRCHDTP,PRCHKEY,PRCHPONO,PRCHT,PRCHTP,PRCHTYP,X,Y,Z
Q
;
EN3 ;CREATE REPORT OF CODE SHEETS TO BE GENERATED, FOR PPM
;
LCK1 S DIC="^PRC(442,"
;
LCK I $G(DA) D
. S HLDDA=DA
E D
. S:$G(PRCHPO) (HLDDA,DA)=PRCHPO
L @("+"_DIC_DA_"):0") E W !,$C(7),"ANOTHER USER IS EDITING THIS ENTRY!" K DA
Q
UNLCK ;
I $G(HLDDA) D
. S DA=HLDDA
E D
. S:$G(PRCHPO) DA=PRCHPO
S DIC="^PRC(442,"
L @("-"_DIC_DA_")")
K HLDDA
G @TAGLCK
Q
;
ST S PRCF("X")="S" D ^PRCFSITE
Q
;
PO S PRCHP("S")="""13478""[$P(^(0),U,2),"_PRCHP("S"),PRCHP("A")="P.O./REQ.NO.: " D EN3^PRCHPAT Q:'$D(PRCHPO) Q:'PRCHPO
S PRCHSAVX=X S:'$D(^PRC(442,PRCHPO,18)) ^(18)="" I $P(^(18),U,3)="" D DOCID^PRCHUTL K Z
S:'$D(^PRC(442,PRCHPO,17)) ^(17)="" I $P(^(17),U,1)="" D LOGDPT^PRCHEC2
S X=PRCHSAVX K PRCHSAVX
Q
;
GT S PRCHLOG=1,PRCFASYS="LOG" D TT^PRCFAC Q:'% S PRCFA("TTF")=PRCFA("TT")
K PRCHTP S PRCHTP(1)="442,"_PRCHPO_",^PRC(442,",PRCHTP(2)="442.01,PRCHLI,^PRC(442,"_PRCHPO_",2,"
Q
;
ERR W !?3,"LOG code sheets already created and signed. Use Edit A Code Sheet option.",$C(7)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHEC 4457 printed Sep 23, 2025@19:43:12 Page 2
PRCHEC ;SF-ISC/TKW-EDIT FOR SUPPLY SYSTEM--LOG CODE SHEETS ; 5/17/00 4:05pm
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
EN1 ;CREATE ACQUISITIONS LOG CODE SHEETS, UPDATE OBLIGATED BALANCE (IF SUPPLY FUND P.O.)
+1 DO ST
if '$DATA(PRC("SITE"))
GOTO Q
DO ASK^PRCHEC1
if %=-1
GOTO Q
IF %=1
SET PRCHQ="EN1"
DO EN^PRCHRCS
EN01 if '$DATA(PRC("SITE"))
QUIT
if $DATA(PRCHENT)
GOTO Q2
SET PRCHP("S")="$D(^PRC(442,""AE"",""N"",+Y))"
DO PO
if '$DATA(PRCHPO)
GOTO Q
+1 IF '$DATA(PRCHENT)
DO LCK1
if '$DATA(DA)
GOTO EN01
+2 IF $DATA(^PRC(442,PRCHPO,1))
IF "013"[$PIECE(^(1),U,7)
SET PRCHNRQ=1
+3 SET %=1
SET %B=""
SET %A=" Review Order "
DO ^PRCFYN
if %=-1
GOTO Q
IF %=1
SET D0=PRCHPO
DO ^PRCHDP1
+4 ;
EN11 ;ENTRY POINT IF CALLED WHEN REQUISITION SIGNED.
+1 SET TAGLCK="EN01"
+2 DO SETUP^PRCHEC1
DO CAL2^PRCHEC2
+3 IF PRCHN("SFC")=2
IF PRCHN("MP")'=12
IF '$DATA(PRCHNRQ)
DO OBL^PRCHEC1
if '$DATA(PRCHPO)
GOTO Q
IF $PIECE(^PRC(442,PRCHPO,0),U,2)=3
SET X=40
SET DA=PRCHPO
DO ENS^PRCHSTAT
+4 IF $DATA(^PRC(442,PRCHPO,18))
IF $PIECE(^(18),U,6)]""
DO ERR
if '$DATA(PRCHENT)
GOTO UNLCK
GOTO EN01
+5 ;CALL FROM PRCHNRQ ROUTINE.
IF $DATA(PRCHENT)
DO LCK1
if '$DATA(DA)
GOTO EN01
+6 SET PRCHTYP="A"
DO EDIT^PRCHEC1
if '$DATA(PRCHPO)
GOTO UNLCK
SET PRCHKEY=PRCHPONO
WRITE !!!
+7 IF PRCHN("SFC")'=2&("013"'[(PRCHN("SC")))
WRITE $CHAR(7),!,"NOT POSTED STOCK AND NOT A REQUISITION--ACQUISITION CODE SHEETS ARE",!,"NOT REQUIRED!!"
GOTO UNLCK
+8 IF $DATA(PRCHNRQ)
IF PRCHN("SFC")=2
SET PRCFA("DICS")=$SELECT(PRCHN("SC")=0:"I Y=100",PRCHN("SC")=1:"I Y=500!(Y=504)",PRCHN("SC")=3:"I Y=630",1:"I Y=630")
+9 IF $DATA(PRCHNRQ)
IF PRCHN("SFC")'=2
SET PRCFA("DICS")=$SELECT(PRCHN("SC")=0:"I Y=100",PRCHN("SC")=1:"I Y=501!(Y=505)!(Y=510)!(Y=514)!(Y=515)",1:"I Y=700")
+10 IF '$DATA(PRCHNRQ)
SET PRCFA("DICS")="I Y=630"
+11 SET PRCFA("TT")=+$PIECE(PRCFA("DICS"),"=",2)
+12 IF '$DATA(PRCHISMS)
DO GT
if '%
GOTO UNLCK
+13 SET Y=PRCFA("TT")
SET X=$SELECT(Y=100:"B100",Y=700:"B700","501.505.510.514.515"[Y:"B501",1:"B500")
SET X=X_"^PRCHCS2"
DO @X
+14 DO SC^PRCHCS0
DO ^PRCHCS
GOTO UNLCK
+15 ;
EN2 ;CREATE LOG RECEIPT CODE SHEETS
+1 DO ST
if '$DATA(PRC("SITE"))
GOTO Q
DO ASK^PRCHEC1
if %=-1
GOTO Q
IF %=1
SET PRCHQ="EN2"
DO EN^PRCHRCS
+2 ;
EN20 if '$DATA(PRC("SITE"))
QUIT
SET PRCHP("S")="$D(^PRC(442,""AF"",""N"",+Y))"
+1 SET TAGLCK="EN20"
DO PO
if '$DATA(PRCHPO)
GOTO Q
IF X<25!(X>44)
WRITE $CHAR(7)," ??"
GOTO EN20
+2 DO LCK1
if '$DATA(DA)
GOTO EN20
+3 IF '$ORDER(^PRC(442,PRCHPO,11,0))
WRITE !?3,"P.O. has no Receiving Reports !",$CHAR(7)
GOTO UNLCK
+4 SET DIC="^PRC(442,PRCHPO,11,"
SET DIC(0)="QEANZ"
DO ^DIC
KILL DIC
+5 IF Y<0
GOTO UNLCK
+6 SET (PRCHRPT,PRCHDPT)=+Y
IF '$DATA(Y(0))
GOTO UNLCK
+7 SET (PRCHRD,PRCHDRD)=$PIECE(Y(0),U,1)
SET PRCHCMI=$SELECT($PIECE(Y(0),U,9)="":"P",1:"")
+8 IF $DATA(^PRC(442,PRCHPO,11,PRCHRPT,1))
IF $PIECE(^(1),U,4)]""
DO ERR
GOTO UNLCK
+9 DO SETUP^PRCHEC1
DO CALTOT^PRCHEC2
SET PRCHTYP="R"
DO EDIT^PRCHEC1
+10 IF '$DATA(PRCHPO)
GOTO UNLCK
+11 SET PRCHKEY=PRCHPONO_"."_PRCHRPT
+12 SET PRCHDIET=$PIECE($GET(^PRC(442,PRCHPO,11,PRCHRPT,1)),U,2)
SET PRCHDTP=1
+13 WRITE !!!
SET %A="DISPLAY RECEIVING REPORT ONLINE "
SET %=2
DO ^PRCFYN
+14 IF %=-1
GOTO UNLCK
+15 IF %=1
DO ^PRCHDP3
+16 WRITE !!!
+17 SET PRCFA("DICS")=$SELECT(PRCHN("SC")=1&(PRCHN("SFC")=2):"I Y=551",PRCHN("SC")=1:"I Y=552",PRCHN("SFC")=2:"I Y=632!(Y=633)",1:"I Y=710!(Y=711)")
+18 SET PRCFA("TT")=+$PIECE(PRCFA("DICS"),"=",2)
SET PRCHN("FMO")=$EXTRACT("1234567890JK",+$EXTRACT(PRCHRD,4,5))
+19 DO GT
if '%
GOTO UNLCK
+20 SET Y=PRCFA("TT")
SET X=$SELECT(Y=551:"B551",Y=552:"B552",Y=710:"B710",1:"B632")
SET X=X_"^PRCHCS7"
DO @X
+21 IF PRCFA("TT")["55"
Begin DoDot:1
+22 DO ^PRCHCS8
End DoDot:1
+23 IF '$TEST
Begin DoDot:1
+24 DO SC^PRCHCS0
DO ^PRCHCS
End DoDot:1
+25 GOTO UNLCK
+26 ;
Q KILL PRC,PRCHPO,PRCHN,PRCHNM,PRCHNRQ,TAGLCK
+1 ;
Q2 KILL PRCF,PRCFA,PRCFASYS,PRCHCS,PRCHTP,PRCHAMT,PRCHCNT,PRCHENT,PRCHRPT,PRCHRD,PRCHCMI,PRCHEMG,PRCHEST,PRCHFA,PRCHLOG,PRCHDIET,PRCHDPT,PRCHDRD,PRCHDT,PRCHDTP,PRCHKEY,PRCHPONO,PRCHT,PRCHTP,PRCHTYP,X,Y,Z
+1 QUIT
+2 ;
EN3 ;CREATE REPORT OF CODE SHEETS TO BE GENERATED, FOR PPM
+1 ;
LCK1 SET DIC="^PRC(442,"
+1 ;
LCK IF $GET(DA)
Begin DoDot:1
+1 SET HLDDA=DA
End DoDot:1
+2 IF '$TEST
Begin DoDot:1
+3 if $GET(PRCHPO)
SET (HLDDA,DA)=PRCHPO
End DoDot:1
+4 LOCK @("+"_DIC_DA_"):0")
IF '$TEST
WRITE !,$CHAR(7),"ANOTHER USER IS EDITING THIS ENTRY!"
KILL DA
+5 QUIT
UNLCK ;
+1 IF $GET(HLDDA)
Begin DoDot:1
+2 SET DA=HLDDA
End DoDot:1
+3 IF '$TEST
Begin DoDot:1
+4 if $GET(PRCHPO)
SET DA=PRCHPO
End DoDot:1
+5 SET DIC="^PRC(442,"
+6 LOCK @("-"_DIC_DA_")")
+7 KILL HLDDA
+8 GOTO @TAGLCK
+9 QUIT
+10 ;
ST SET PRCF("X")="S"
DO ^PRCFSITE
+1 QUIT
+2 ;
PO SET PRCHP("S")="""13478""[$P(^(0),U,2),"_PRCHP("S")
SET PRCHP("A")="P.O./REQ.NO.: "
DO EN3^PRCHPAT
if '$DATA(PRCHPO)
QUIT
if 'PRCHPO
QUIT
+1 SET PRCHSAVX=X
if '$DATA(^PRC(442,PRCHPO,18))
SET ^(18)=""
IF $PIECE(^(18),U,3)=""
DO DOCID^PRCHUTL
KILL Z
+2 if '$DATA(^PRC(442,PRCHPO,17))
SET ^(17)=""
IF $PIECE(^(17),U,1)=""
DO LOGDPT^PRCHEC2
+3 SET X=PRCHSAVX
KILL PRCHSAVX
+4 QUIT
+5 ;
GT SET PRCHLOG=1
SET PRCFASYS="LOG"
DO TT^PRCFAC
if '%
QUIT
SET PRCFA("TTF")=PRCFA("TT")
+1 KILL PRCHTP
SET PRCHTP(1)="442,"_PRCHPO_",^PRC(442,"
SET PRCHTP(2)="442.01,PRCHLI,^PRC(442,"_PRCHPO_",2,"
+2 QUIT
+3 ;
ERR WRITE !?3,"LOG code sheets already created and signed. Use Edit A Code Sheet option.",$CHAR(7)
+1 QUIT
