PRCFAC ;WISC/CTB-CODE SHEET GENERATOR ; 05/11/93 10:46 AM
V ;;5.1;IFCAP;**97**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
LOG ;CREATE LOG CODE SHEETS
S PRCHLOG="" D EN1 K PRCHLOG,PRCFASYS Q
NEWCS K DA,PRCFDEL L +^PRCF(423,0):1 I '$T W $C(7),"Batching or purging is now going on.",!," Code sheet operations are temporarily suspended.",! Q
S X=PRC("SITE")_"-CSC-"_PRC("FY") D COUNTER^PRCFACP I Y<0 K DA Q
S X=Y_"-"_PRC("FY") S:$D(PRCFA("KP")) X="KP-"_X G:$D(^PRCF(423,"B",X)) NEWCS S DLAYGO=423,DIC=423,DIC(0)="LZ" D ^DIC K DLAYGO Q:Y<0 G:$P(Y,U,3)'=1 NEWCS
G:$P(Y,"^",3)'=1 NEWCS W:'$D(PRCHAUTO) !!,"THIS CODE SHEET HAS BEEN ASSIGNED ID # ",$P(Y(0),U),!! S PRCFA("CSNAME")=$P(Y(0),"^")
S (PRCFA("CSDA"),DA)=+Y I '$D(PRCFA("TTDATE")) D NOW^%DTC K %,%H,%I S PRCFA("TTDATE")=$E(X,4,7)_$E(X,2,3)
S X=$P(^PRCF(423,+Y,0),U,1)_U_PRC("SITE")_U_PRCFA("EDIT")_U_PRCFA("TT")_U_PRCFA("TTDATE")_U_$S($D(PRCFA("REF")):$P(PRCFA("REF"),"^"),1:"")
S X=X_"^^"_$S($D(PRC("PER")):+PRC("PER"),1:"")_"^^"_$S($D(PRCFA("SYS")):PRCFA("SYS"),1:"")
S ^PRCF(423,+Y,0)=X,$P(^("TRANS"),U,1)="",$P(^("TRANS"),U,15)=$G(PRCFA("TTLEN"))
I $D(PRCFA("REF")),PRCFA("REF")]"" S ^PRCF(423,"C",PRCFA("REF"),+Y)=""
K C,DIC,X,Y I '$D(PRCHLOG) K PRCFA("REF"),PRCFA("TTLEN")
Q
TT K PRCFDEL S:$D(PRCFA("TT")) DIC("B")=PRCFA("TT") S DIC("A")="Select LOG TRANSACTION TYPE: " S DIC=420.4,DIC(0)="AEQMNZ"
I '$D(PRCFASYS) S PRCFASYS=$S('$D(PRCHLOG):"FEEFENIRSISMCLIPRC",1:"LOG")
S DIC("S")="I PRCFASYS[$P(^(0),U,6)" I $D(PRCFA("DICS")) S DIC("S")=DIC("S")_" "_PRCFA("DICS")
;I $D(PRCFA("ARCS")) S DIC("S")="I $P(^(0),U,7)=1"
W:'$D(PRCFA("TTF")) ! S:$D(PRCFA("TTF")) X=PRCFA("TTF"),DIC(0)="MNZ" D ^DIC K DIC I +Y<0 S %=0 Q
I "PRC"'[PRCFASYS,$P(Y(0),U,3)=""!($P(Y(0),U,5)'="Y") W !,"THIS TRANSACTION TYPE IS NOT YET ",$S($P(Y(0),"^",5)'="Y":"ACTIVATED",1:"AVAILABLE"),$C(7) Q:$D(PRCFA("TTF")) G TT
S PRCFA("TT")=$P(Y(0),U,1),PRCFA("TTDA")=+Y,PRCFA("EDIT")=$P(Y(0),U,3),PRCFA("SYS")=$P(Y(0),"^",6),PRCFA("TTLEN")=$P(Y(0),"^",8),%=1
;K C,Y Q
Q
SE S U="^" D ^PRCFSITE G:'% OUT
S %DT="",X="T" D ^%DT S PRCFA("TTDATE")=$E(Y,4,7)_$E(Y,2,3) Q
EN1 ;CREATE A CODE SHEET
K PRCFDEL,PRCFA("PODA") G:$D(PRCFAA) OUT
S PRCF("X")="AS" D SE G:'$D(PRC("SITE")) OUT
AM D TT G OUT:%'>0,EN1:'% D NEWCS G:'$D(DA) OUT S DIE="^PRCF(423,"
S DR=PRCFA("EDIT") D ^DIE I $D(Y)=0 D ^PRCFACXM S X=PRCFA("TT"),X1=PRCFA("TTDATE") K PRCFA,P,PO,PODA S PRCFA("TT")=X,PRCFA("TTDATE")=X1 K X,X1 G EN1
D DEL^PRCFACXM,OUT1 G EN1
OUT1 K %,%DT,%X,%Y,A,B,C,DIG,DIH,DIU,DIV,DIW,DIK,DQ,I,M,N,PRCFASYS,X1,XL1 Q
EN2 ;EDIT EXISTING TRANSACTION
K PRCFDEL S PRCF("X")="AS" D SE G:'$D(PRC("SITE")) OUT K Q1
S:'$D(PRCFASYS) PRCFASYS="FEEFENIRSCLI" K Q1 S DIC="^PRCF(423,",DIC(0)="AEMNQZ",DIC("S")="S ZX=^(0) I $P(ZX,U,10)]"""",PRCFASYS[$P(ZX,U,10),$P(ZX,U,2)=PRC(""SITE"")" D ^DIC K DIC("A") I Y<0 K PRCFASYS G OUT
K DIE S DA=+Y,PRCFA("CSDA")=DA,DIE=DIC,PRCFA("EDIT")=$P(Y(0),"^",3),PRCFA("SYS")=$P(Y(0),"^",10),PRCFA("TTLEN")=$P(^PRCF(423,DA,"TRANS"),"^",15) K DIC
I $P(Y,"^",2)["KP" W $C(7),!,"Code Sheet has been Key Punched and may not be edited with this option." G EN2
EN21 S DR="" S:$D(PRCFA("EDIT")) DR=PRCFA("EDIT") S:$D(Y(0)) DR=$P(Y(0),U,3),PRCFA("TT")=$P(Y(0),"^",4) I DR="" W !,"THIS CODE SHEET CANNOT BE EDITED, IT MUST BE RE-ENTERED UNDER ANOTHER NUMBER.",$C(7) G EN2
D ^DIE,^PRCFACXM G EN2
OUT K %,B,D,D0,DA,DG,DIC,DIE,DIG,DIH,DIU,DIV,DIW,DLAYGO,DQ,DR,I,J,K,M,N,PRCFA,PRCFASYS,Q,Q1,S,X,XL1,Y,Z,PRCENT Q
EN73 D ^PRCFSITE G:'% OUT
EN731 K DIC("A") S D="C",DIC("S")="I $D(^(7)),+$P(^(0),U)=PRC(""SITE"") S FSO=$P(^PRCD(442.3,+^(7),0),U,3) I FSO=10",DIC("A")="Select Purchase Order Number: ",DIC=442,DIC(0)="AEQZ" D IX^DIC K DIC("S"),DIC("A"),FSO G:+Y<0 OUT S DA=+Y
EN732 W !,$C(7) S %A="Are you sure that you do not want to obligate this order"
S %=1,%B="Answering 'YES' will return the order to Supply, unobligated." D ^PRCFYN S PRCENT=% D:PRCENT=1 ^PRCFACS1 G:PRCENT=2 EN731 I PRCENT<0 W !,"No Action Taken." R X:3 G OUT
LCK L @("+"_DIC_DA_"):0") E W !,$C(7),"ANOTHER USER IS EDITING THIS ENTRY!" K DA Q
D REMOVE^PRCHES5(DA) S X=8 D ENF^PRCHSTAT W !!,"...Purchase Order has been returned, Supply has been notified...",$C(7),!
I $G(DIC),$G(DA) L @("-"_DIC_DA_"):0")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFAC 4303 printed Oct 16, 2024@18:02:32 Page 2
PRCFAC ;WISC/CTB-CODE SHEET GENERATOR ; 05/11/93 10:46 AM
V ;;5.1;IFCAP;**97**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
LOG ;CREATE LOG CODE SHEETS
+1 SET PRCHLOG=""
DO EN1
KILL PRCHLOG,PRCFASYS
QUIT
NEWCS KILL DA,PRCFDEL
LOCK +^PRCF(423,0):1
IF '$TEST
WRITE $CHAR(7),"Batching or purging is now going on.",!," Code sheet operations are temporarily suspended.",!
QUIT
+1 SET X=PRC("SITE")_"-CSC-"_PRC("FY")
DO COUNTER^PRCFACP
IF Y<0
KILL DA
QUIT
+2 SET X=Y_"-"_PRC("FY")
if $DATA(PRCFA("KP"))
SET X="KP-"_X
if $DATA(^PRCF(423,"B",X))
GOTO NEWCS
SET DLAYGO=423
SET DIC=423
SET DIC(0)="LZ"
DO ^DIC
KILL DLAYGO
if Y<0
QUIT
if $PIECE(Y,U,3)'=1
GOTO NEWCS
+3 if $PIECE(Y,"^",3)'=1
GOTO NEWCS
if '$DATA(PRCHAUTO)
WRITE !!,"THIS CODE SHEET HAS BEEN ASSIGNED ID # ",$PIECE(Y(0),U),!!
SET PRCFA("CSNAME")=$PIECE(Y(0),"^")
+4 SET (PRCFA("CSDA"),DA)=+Y
IF '$DATA(PRCFA("TTDATE"))
DO NOW^%DTC
KILL %,%H,%I
SET PRCFA("TTDATE")=$EXTRACT(X,4,7)_$EXTRACT(X,2,3)
+5 SET X=$PIECE(^PRCF(423,+Y,0),U,1)_U_PRC("SITE")_U_PRCFA("EDIT")_U_PRCFA("TT")_U_PRCFA("TTDATE")_U_$SELECT($DATA(PRCFA("REF")):$PIECE(PRCFA("REF"),"^"),1:"")
+6 SET X=X_"^^"_$SELECT($DATA(PRC("PER")):+PRC("PER"),1:"")_"^^"_$SELECT($DATA(PRCFA("SYS")):PRCFA("SYS"),1:"")
+7 SET ^PRCF(423,+Y,0)=X
SET $PIECE(^("TRANS"),U,1)=""
SET $PIECE(^("TRANS"),U,15)=$GET(PRCFA("TTLEN"))
+8 IF $DATA(PRCFA("REF"))
IF PRCFA("REF")]""
SET ^PRCF(423,"C",PRCFA("REF"),+Y)=""
+9 KILL C,DIC,X,Y
IF '$DATA(PRCHLOG)
KILL PRCFA("REF"),PRCFA("TTLEN")
+10 QUIT
TT KILL PRCFDEL
if $DATA(PRCFA("TT"))
SET DIC("B")=PRCFA("TT")
SET DIC("A")="Select LOG TRANSACTION TYPE: "
SET DIC=420.4
SET DIC(0)="AEQMNZ"
+1 IF '$DATA(PRCFASYS)
SET PRCFASYS=$SELECT('$DATA(PRCHLOG):"FEEFENIRSISMCLIPRC",1:"LOG")
+2 SET DIC("S")="I PRCFASYS[$P(^(0),U,6)"
IF $DATA(PRCFA("DICS"))
SET DIC("S")=DIC("S")_" "_PRCFA("DICS")
+3 ;I $D(PRCFA("ARCS")) S DIC("S")="I $P(^(0),U,7)=1"
+4 if '$DATA(PRCFA("TTF"))
WRITE !
if $DATA(PRCFA("TTF"))
SET X=PRCFA("TTF")
SET DIC(0)="MNZ"
DO ^DIC
KILL DIC
IF +Y<0
SET %=0
QUIT
+5 IF "PRC"'[PRCFASYS
IF $PIECE(Y(0),U,3)=""!($PIECE(Y(0),U,5)'="Y")
WRITE !,"THIS TRANSACTION TYPE IS NOT YET ",$SELECT($PIECE(Y(0),"^",5)'="Y":"ACTIVATED",1:"AVAILABLE"),$CHAR(7)
if $DATA(PRCFA("TTF"))
QUIT
GOTO TT
+6 SET PRCFA("TT")=$PIECE(Y(0),U,1)
SET PRCFA("TTDA")=+Y
SET PRCFA("EDIT")=$PIECE(Y(0),U,3)
SET PRCFA("SYS")=$PIECE(Y(0),"^",6)
SET PRCFA("TTLEN")=$PIECE(Y(0),"^",8)
SET %=1
+7 ;K C,Y Q
+8 QUIT
SE SET U="^"
DO ^PRCFSITE
if '%
GOTO OUT
+1 SET %DT=""
SET X="T"
DO ^%DT
SET PRCFA("TTDATE")=$EXTRACT(Y,4,7)_$EXTRACT(Y,2,3)
QUIT
EN1 ;CREATE A CODE SHEET
+1 KILL PRCFDEL,PRCFA("PODA")
if $DATA(PRCFAA)
GOTO OUT
+2 SET PRCF("X")="AS"
DO SE
if '$DATA(PRC("SITE"))
GOTO OUT
AM DO TT
if %'>0
GOTO OUT
if '%
GOTO EN1
DO NEWCS
if '$DATA(DA)
GOTO OUT
SET DIE="^PRCF(423,"
+1 SET DR=PRCFA("EDIT")
DO ^DIE
IF $DATA(Y)=0
DO ^PRCFACXM
SET X=PRCFA("TT")
SET X1=PRCFA("TTDATE")
KILL PRCFA,P,PO,PODA
SET PRCFA("TT")=X
SET PRCFA("TTDATE")=X1
KILL X,X1
GOTO EN1
+2 DO DEL^PRCFACXM
DO OUT1
GOTO EN1
OUT1 KILL %,%DT,%X,%Y,A,B,C,DIG,DIH,DIU,DIV,DIW,DIK,DQ,I,M,N,PRCFASYS,X1,XL1
QUIT
EN2 ;EDIT EXISTING TRANSACTION
+1 KILL PRCFDEL
SET PRCF("X")="AS"
DO SE
if '$DATA(PRC("SITE"))
GOTO OUT
KILL Q1
+2 if '$DATA(PRCFASYS)
SET PRCFASYS="FEEFENIRSCLI"
KILL Q1
SET DIC="^PRCF(423,"
SET DIC(0)="AEMNQZ"
SET DIC("S")="S ZX=^(0) I $P(ZX,U,10)]"""",PRCFASYS[$P(ZX,U,10),$P(ZX,U,2)=PRC(""SITE"")"
DO ^DIC
KILL DIC("A")
IF Y<0
KILL PRCFASYS
GOTO OUT
+3 KILL DIE
SET DA=+Y
SET PRCFA("CSDA")=DA
SET DIE=DIC
SET PRCFA("EDIT")=$PIECE(Y(0),"^",3)
SET PRCFA("SYS")=$PIECE(Y(0),"^",10)
SET PRCFA("TTLEN")=$PIECE(^PRCF(423,DA,"TRANS"),"^",15)
KILL DIC
+4 IF $PIECE(Y,"^",2)["KP"
WRITE $CHAR(7),!,"Code Sheet has been Key Punched and may not be edited with this option."
GOTO EN2
EN21 SET DR=""
if $DATA(PRCFA("EDIT"))
SET DR=PRCFA("EDIT")
if $DATA(Y(0))
SET DR=$PIECE(Y(0),U,3)
SET PRCFA("TT")=$PIECE(Y(0),"^",4)
IF DR=""
WRITE !,"THIS CODE SHEET CANNOT BE EDITED, IT MUST BE RE-ENTERED UNDER ANOTHER NUMBER.",$CHAR(7)
GOTO EN2
+1 DO ^DIE
DO ^PRCFACXM
GOTO EN2
OUT KILL %,B,D,D0,DA,DG,DIC,DIE,DIG,DIH,DIU,DIV,DIW,DLAYGO,DQ,DR,I,J,K,M,N,PRCFA,PRCFASYS,Q,Q1,S,X,XL1,Y,Z,PRCENT
QUIT
EN73 DO ^PRCFSITE
if '%
GOTO OUT
EN731 KILL DIC("A")
SET D="C"
SET DIC("S")="I $D(^(7)),+$P(^(0),U)=PRC(""SITE"") S FSO=$P(^PRCD(442.3,+^(7),0),U,3) I FSO=10"
SET DIC("A")="Select Purchase Order Number: "
SET DIC=442
SET DIC(0)="AEQZ"
DO IX^DIC
KILL DIC("S"),DIC("A"),FSO
if +Y<0
GOTO OUT
SET DA=+Y
EN732 WRITE !,$CHAR(7)
SET %A="Are you sure that you do not want to obligate this order"
+1 SET %=1
SET %B="Answering 'YES' will return the order to Supply, unobligated."
DO ^PRCFYN
SET PRCENT=%
if PRCENT=1
DO ^PRCFACS1
if PRCENT=2
GOTO EN731
IF PRCENT<0
WRITE !,"No Action Taken."
READ X:3
GOTO OUT
LCK LOCK @("+"_DIC_DA_"):0")
IF '$TEST
WRITE !,$CHAR(7),"ANOTHER USER IS EDITING THIS ENTRY!"
KILL DA
QUIT
+1 DO REMOVE^PRCHES5(DA)
SET X=8
DO ENF^PRCHSTAT
WRITE !!,"...Purchase Order has been returned, Supply has been notified...",$CHAR(7),!
+2 IF $GET(DIC)
IF $GET(DA)
LOCK @("-"_DIC_DA_"):0")
+3 QUIT
