source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFAC.m@ 1141

Last change on this file since 1141 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.2 KB
Line 
1PRCFAC ;WISC/CTB-CODE SHEET GENERATOR ; 05/11/93 10:46 AM
2V ;;5.1;IFCAP;**97**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4LOG ;CREATE LOG CODE SHEETS
5 S PRCHLOG="" D EN1 K PRCHLOG,PRCFASYS Q
6NEWCS 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
7 S X=PRC("SITE")_"-CSC-"_PRC("FY") D COUNTER^PRCFACP I Y<0 K DA Q
8 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
9 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),"^")
10 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)
11 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:"")
12 S X=X_"^^"_$S($D(PRC("PER")):+PRC("PER"),1:"")_"^^"_$S($D(PRCFA("SYS")):PRCFA("SYS"),1:"")
13 S ^PRCF(423,+Y,0)=X,$P(^("TRANS"),U,1)="",$P(^("TRANS"),U,15)=$G(PRCFA("TTLEN"))
14 I $D(PRCFA("REF")),PRCFA("REF")]"" S ^PRCF(423,"C",PRCFA("REF"),+Y)=""
15 K C,DIC,X,Y I '$D(PRCHLOG) K PRCFA("REF"),PRCFA("TTLEN")
16 Q
17TT K PRCFDEL S:$D(PRCFA("TT")) DIC("B")=PRCFA("TT") S DIC("A")="Select LOG TRANSACTION TYPE: " S DIC=420.4,DIC(0)="AEQMNZ"
18 I '$D(PRCFASYS) S PRCFASYS=$S('$D(PRCHLOG):"FEEFENIRSISMCLIPRC",1:"LOG")
19 S DIC("S")="I PRCFASYS[$P(^(0),U,6)" I $D(PRCFA("DICS")) S DIC("S")=DIC("S")_" "_PRCFA("DICS")
20 ;I $D(PRCFA("ARCS")) S DIC("S")="I $P(^(0),U,7)=1"
21 W:'$D(PRCFA("TTF")) ! S:$D(PRCFA("TTF")) X=PRCFA("TTF"),DIC(0)="MNZ" D ^DIC K DIC I +Y<0 S %=0 Q
22 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
23 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
24 ;K C,Y Q
25 Q
26SE S U="^" D ^PRCFSITE G:'% OUT
27 S %DT="",X="T" D ^%DT S PRCFA("TTDATE")=$E(Y,4,7)_$E(Y,2,3) Q
28EN1 ;CREATE A CODE SHEET
29 K PRCFDEL,PRCFA("PODA") G:$D(PRCFAA) OUT
30 S PRCF("X")="AS" D SE G:'$D(PRC("SITE")) OUT
31AM D TT G OUT:%'>0,EN1:'% D NEWCS G:'$D(DA) OUT S DIE="^PRCF(423,"
32 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
33 D DEL^PRCFACXM,OUT1 G EN1
34OUT1 K %,%DT,%X,%Y,A,B,C,DIG,DIH,DIU,DIV,DIW,DIK,DQ,I,M,N,PRCFASYS,X1,XL1 Q
35EN2 ;EDIT EXISTING TRANSACTION
36 K PRCFDEL S PRCF("X")="AS" D SE G:'$D(PRC("SITE")) OUT K Q1
37 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
38 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
39 I $P(Y,"^",2)["KP" W $C(7),!,"Code Sheet has been Key Punched and may not be edited with this option." G EN2
40EN21 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
41 D ^DIE,^PRCFACXM G EN2
42OUT 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
43EN73 D ^PRCFSITE G:'% OUT
44EN731 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
45EN732 W !,$C(7) S %A="Are you sure that you do not want to obligate this order"
46 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
47LCK L @("+"_DIC_DA_"):0") E W !,$C(7),"ANOTHER USER IS EDITING THIS ENTRY!" K DA Q
48 D REMOVE^PRCHES5(DA) S X=8 D ENF^PRCHSTAT W !!,"...Purchase Order has been returned, Supply has been notified...",$C(7),!
49 I $G(DIC),$G(DA) L @("-"_DIC_DA_"):0")
50 Q
Note: See TracBrowser for help on using the repository browser.