source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSECP.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: 5.7 KB
Line 
1PRCSECP ;SF-ISC/KSS,LJP/DAP-COPY A TRANSACTION ;10-30-91/10:50
2V ;;5.1;IFCAP;**81**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4A I '$D(DT) S %DT="",X="T" D ^%DT S DT=Y
5 W @IOF,!!
6B D EN3^PRCSUT ;GO GET STATION AND CONTROL POINT
7 I '$D(PRC("SITE"))!('$D(PRC("CP")))!(Y<0)!('$D(X))!($G(X)[U) D END Q
8 N GET,GET1 S DIC="^PRCS(410,",DIC(0)="AEQM"
9 S DIC("S")="S PRCST=$P(^(0),U,2) I $D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),""^"",5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2))) I PRCST=""O""!(PRCST=""CA"")"
10 S DIC("A")="Select the Transaction to be copied: "
11C W ! D ^PRCSDIC K PRCST
12 I (X[U)!(Y<0) D END Q
13 S DA=+Y D W1
14 S PRCVFT=$P(^PRCS(410,DA,0),"^",4)
15 ;*81 Check site parameter to see if Issue Books are allowed
16 I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 S PRCVZ=1
17 I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1 S PRCVZ=0
18 I PRCVZ=1,PRCVFT=5 W !,"All Supply Warehouse requests must be processed in the new Inventory System.",!!,"Please cancel this IFCAP issue book order." D W3 G:%'=1 END W !! K PRCS,PRCS2 G B
19 W !!,"Would you like to proceed " S %=1 D YN^DICN G C:%'=1
20 S DIC="^PRCS(410," L +^PRCS(410,DA):15 G END:$T=0
21 S T1=DA,T2=^PRCS(410,DA,0),T5=$P(T2,U,4),T4=$P(T2,U,2),T2=$P(T2,U),T3=$P(^(3),U)
22 K ^TMP($J)
23 S ^TMP($J,"OLDDA")=DA,^("OLDTXN")=$P(T2,U,1),^("OLDFCP")=PRC("CP")
24 W !!,"Now enter the information for the new transaction number.",!
25 ;L -^PRCS(410,DA)
26 K DA,DIC,Y D EN1^PRCSUT K DA,DIC
27 I ('$D(PRC("SITE")))!('$D(PRC("QTR")))!('$D(PRC("CP"))) G UNLKEND
28 S X1=X,PRCSAPP=$P(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),U,3)
29 I PRC("CP")'=T3,PRCSAPP["_" D PRCFY^PRCSUT2 I (PRCSAPP["_") G UNLKEND
30 S X=X1 D EN1^PRCSUT3 I 'X G UNLKEND
31 S X1=X D EN2^PRCSUT3 I ('$D(X1)) G UNLKEND
32 S (X,^TMP($J,"NEWTXN"))=X1
33 W !!,"This transaction is assigned transaction number: ",X
34 ;L +^PRCS(410,DA):15 G B:$T=0
35 I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) S:$P(^(0),U,11)="Y" PRCS2=1
36TYPE ;
37 S PRCSX=$P(^PRCS(410,T1,0),"^",4)
38 ;*81 Check site parameter to see if issue books should be allowed
39 I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 S PRCVX="I Y>(.5)&(Y<5)",PRCVY="The Issue Book and NO FORM types are no longer used."
40 I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1 S PRCVX="I Y>(.5)",PRCVY="The NO FORM type is no longer used."
41 I PRCSX<1 W !,PRCVY,!,"Please enter another form type.",! S PRCDAA=DA,DIC="^PRCS(410.5,",DIC("S")=PRCVX,DIC("A")="FORM TYPE: ",DIC(0)="AEQZ" D ^DIC S:Y=-1 Y=2 S DA=PRCDAA,PRCSX=+Y
42 S (DIE,DIC)="^PRCS(410,"
43 K PRCVX,PRCVY
44 S $P(^PRCS(410,DA,0),"^",4)=PRCSX
45 W !,"The form type for this request is: ",$P($G(^PRCS(410.5,PRCSX,0)),"^"),!
46 W !,?10,"Transaction data is being copied...",!
47 D @$S(PRCSX=1:"S1^PRCSECP1",1:"S2^PRCSECP1") S DIK="^PRCS(410," D IX^DIK
48 S (DIC,DIE)="^PRCS(410,"
49 ;P182--removed warning about changed CC/BOC;replaced w/following call
50 S X=$$CHGCCBOC^PRCSCK(^TMP($J,"OLDTXN"),^TMP($J,"NEWTXN"),^TMP($J,"OLDFCP"),0)
51 S X=PRCSX S:'$D(PRCS2)&(X>2) $P(^PRCS(410,DA,0),"^",4)=2,X=2
52 S (PRCSDR,DR)="["_$S(X=1:"PRCE NEW 1358",X=2:"PRCSEN2237B",X=3:"PRCSENPR",X=4:"PRCSENR&NR",X=5:"PRCSENIB",1:"PRCSENCOD")_"]"
53D K DTOUT,DUOUT,Y S COPYDA=DA D ^DIE I $D(Y)!($D(DTOUT)) S DA=COPYDA G END
54 S DA=COPYDA D RL^PRCSUT1
55 D ^PRCSCK I $D(PRCSERR),PRCSERR G D
56 K PRCSERR
57 I PRCSDR="[PRCSENCOD]" D W7^PRCSEB0 D:$D(PRCSOB) ENOD1^PRCSEB1 K PRCSOB
58 D:PRCSDR'="[PRCSENCOD]" W1 I PRCSDR'="[PRCSENCOD]",$D(PRCS2),+^PRCS(410,DA,0) D W6^PRCSEB
59 S DA=COPYDA L -^PRCS(410,DA) D W3 G END:%'=1 W !! K PRCS,PRCS2
60 G B
61 ;
62UNLKEND S DA=^TMP($J,"OLDDA") L -^PRCS(410,DA)
63END K %,D0,DA,DIC,DIE,DIK,DR,N,P,PRCSAPP,COPYDA,PRCSDR,PRCSERR,PRCSI,PRCSIP,PRCSJ,PRCSJ,PRCSL,PRCST1,PRCSTMP,PRCSTT,PRCSX,PRCSZ,T1,T2,T3,T4,T5,X,X1,Y,PRCVZ,PRCVFT
64 K ^TMP($J)
65 Q
66W1 W !!,"Would you like to review this request" S %=2 D YN^DICN G W1:%=0 Q:%'=1 S (N,PRCSZ)=DA,PRCSF=1 D PRF1^PRCSP1 S DA=PRCSZ K X,PRCSF,PRCSZ Q
67W3 W !!,"Would you like to copy another request" S %=1 D YN^DICN G W3:%=0 Q
68 ;
69GETCCCNT(STA,FCP) ;How many valid Cost Centers for this Control Point
70 ;return count and first CC
71 N GOODCC,CC,FIRSTCC
72 S GOODCC=0,(CC,FIRSTCC)=""
73 F S CC=$O(^PRC(420,+STA,1,+FCP,2,CC)) Q:CC="" D
74 . I $$VALIDCC(STA,FCP,CC) S GOODCC=GOODCC+1 I FIRSTCC="" S FIRSTCC=$E($P(^PRCD(420.1,+CC,0),U,1),1,23)
75 Q GOODCC_"^"_FIRSTCC
76 ;
77VALIDCC(STA,FCP,CC) ;Is this STATION,FCP,COST CENTER combination valid?
78 ;To be valid, station/FCP must point to CC, CC must be active,CC must
79 ;point to some active BOC
80 N X,VALID,BOC,GOODBOC
81 S BOC="",GOODBOC=0
82 S X=$G(^PRC(420,+STA,1,+FCP,2,+CC,0)) I (+X=+CC) D ;FCP => CC
83 . S X=$G(^PRCD(420.1,CC,0)) I X]"",'$P(X,U,2) D ; CC IS ACTIVE
84 .. F S BOC=$O(^PRCD(420.1,+CC,1,BOC)) Q:BOC=""!GOODBOC D
85 ... S X=$G(^PRCD(420.2,+BOC,0)) I X]"",'$P(X,U,2) S GOODBOC=1
86 Q GOODBOC
87 ;
88GETBOCNT(STA,FCP,CC) ;How many valid BOCs for this STATION,FCP,COST CENTER
89 ;To be valid, station/FCP must point to CC, CC must be active,CC must
90 ;point to some active BOC
91 N X,VALID,BOC,GOODBOC,TOTBOCS,FIRSTBOC
92 S BOC="",GOODBOC=0,TOTBOCS=0,FIRSTBOC=""
93 S X=$G(^PRC(420,+STA,1,+FCP,2,+CC,0)) I (+X=+CC) D ;FCP => CC
94 . S X=$G(^PRCD(420.1,CC,0)) I X]"",'$P(X,U,2) D ; CC IS ACTIVE
95 .. F S BOC=$O(^PRCD(420.1,+CC,1,BOC)) Q:BOC="" D
96 ... S X=$G(^PRCD(420.2,+BOC,0)) I X]"",'$P(X,U,2) D
97 .... S TOTBOCS=TOTBOCS+1 I FIRSTBOC="" S FIRSTBOC=$E($P(^PRCD(420.2,+BOC,0),U,1),1,23)
98 Q TOTBOCS_"^"_FIRSTBOC
99 ;
100VALIDBOC(STA,FCP,CC,BOC) ;Is this STATION,FCP,COST CENTER,BOC VALID?
101 ;To be valid, station/FCP must point to CC, CC must be active,CC must
102 ;point to BOC,and BOC must be active
103 N X,VALID,GOODBOC
104 S GOODBOC=0
105 S X=$G(^PRC(420,+STA,1,+FCP,2,+CC,0))
106 I (+X=+CC) S X=$G(^PRCD(420.1,+CC,0)) I X]"",'$P(X,U,2) D
107 . S X=$G(^PRCD(420.1,+CC,1,+BOC,0))
108 . I X]"" S X=$G(^PRCD(420.2,+BOC,0)) I X]"",'$P(X,U,2) S GOODBOC=1
109 Q GOODBOC
110 ;
Note: See TracBrowser for help on using the repository browser.