- 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 Jan 18, 2025@03:02:58 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