source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHG.m@ 975

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

initial load of WorldVistAEHR

File size: 4.7 KB
Line 
1PRCHG ;ID/RSD,SF-ISC/TKW/DAP-PROCESS 2237 ;2/03/98 10:49 AM
2V ;;5.1;IFCAP;**81**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5ES ;SIGN 2237 IN PPM
6 G Q:'$D(PRC("PER"))!('$D(PRC("SITE"))) I $S('$D(^VA(200,+PRC("PER"),400)):1,$P(^(400),U,1)=4:0,$P(^(400),U,1)=2:0,1:1) W !!,"You are not a Supply Accountable Officer !",$C(7) G Q
7 S P=+PRC("PER"),DA=1,PRCSIG="" D ESIG^PRCUESIG(DUZ,.PRCSIG) S ROUTINE="PRCUESIG" G:PRCSIG'=1 QQ S PRCHNM=$P(^VA(200,P,20),U,2)
8 Q
9 ;
10ES1 ;S PRCHG=$S($D(^PRCD(442.3,+$P(^PRC(443,DA,0),U,7),0)):$P(^(0),U,2),1:""),$P(^PRC(443,DA,0),"^",3)="",P=+PRC("PER")
11 S PRCHG=$P($G(^PRCD(442.3,+$P(^PRC(443,DA,0),U,7),0)),U,2),$P(^PRC(443,DA,0),"^",3)="",P=+PRC("PER")
12 I PRCHG=63 S PRCFA("WHO")=3 D RET
13 N DA2237 S DA2237=DA
14 ;
15 ;if PO is not for PPM Clerk stop processing and exit
16 I PRCHG<65 K PRCHG Q
17 S PRCSIG="" D ENCODE^PRCHES11(DA,DUZ,.PRCSIG) S ROUTINE=$T(+0) G:PRCSIG<1 QQ
18 ;set AO name, signature date on 2237 record
19 I $D(DA2237) L +^PRCS(410,DA2237):15 Q:'$T D NOW^%DTC S $P(^PRCS(410,DA2237,7),"^",11)=P,$P(^PRCS(410,DA2237,7),"^",12)=% L -^PRCS(410,DA2237)
20 Q
21 ;
22QQ S:'$D(ROUTINE) ROUTINE=$T(+0) W !!,$$ERR^PRCHQQ(ROUTINE,PRCSIG) W:PRCSIG=0!(PRCSIG=-3) !,"Notify Application Coordinator!",$C(7) S DIR(0)="EAO",DIR("A")="Press <return> to continue" D ^DIR
23 ;
24Q K %,DA,DIC,DIE,DR,P,PRCHNM,PRCHTDA,PRCHG,PRCHPO,PRCHS,PRCHSIT,PRCHSX,PRCHSY,PRCHSZ,PRCHX,ROUTINE
25 Q
26 ;
27RET ;RETURN TO SERVICE--UPDATE CP BALANCES, ERASE CP OFFICIAL SIGNATURE, SEND BULLETIN BACK TO SERVICE
28 S PRCHDA=DA,X=$P(^PRCS(410,DA,4),"^",8) D TRANK^PRCSES S $P(^PRCS(410,DA,7),"^",5,7)="^^",$P(^PRCS(410,DA,10),U,4)=$P(^PRC(443,DA,0),U,7),DIE="^PRCS(410,",DR=61 D ^DIE K DIE
29 S DA=PRCHDA D REMOVE^PRCSC1(DA),REMOVE^PRCSC3(DA)
30 ;remove AO name, signature date from 2237 record
31 N PPMNODE F PPMNODE=11,12 S $P(^PRCS(410,DA,7),"^",PPMNODE)=""
32 S (DA,PRCFA("TRDA"))=PRCHDA D RETURN^PRCEFIS1 S DA=PRCHDA D EN3^PRCPWI
33 Q
34 ;
35SIT S PRCF("X")="SP" D ^PRCFSITE K PRCHNM
36 Q
37 ;
38TR S DIC("S")="I $P(^(0),U,3)="""",$D(^PRCS(410,Y,7)),$P(^(7),U,6)]"""",+^(0)=PRC(""SITE"")"
39 S DIC("S")=$S('$D(PRCFDICS):DIC("S")_" S Z=$O(^PRCD(442.3,""C"",+$P(^PRC(443,Y,0),U,7),0)) I Z'=10&(Z'=85)",1:DIC("S")_PRCFDICS)
40 ;
41DIC W !! K DA S DIC="^PRC(443,",DIC(0)="QEAMZ",DIC("A")="2237 TRANSACTION NUMBER: " D ^DIC S DIE=DIC K DIC S:Y>0 DA=+Y
42 Q
43 ;
44ST S DIC("S")="I $P(^(0),U,3)]"""",$O(^PRCD(442.3,""C"",+$P(^(0),U,7),0))'=65,$D(^PRCS(410,+Y,0)),+^(0)=PRC(""SITE"")" D DIC
45 Q
46 ;
47PPM S DR="[PRCHPPM]",DIE("NO^")="" D ^DIE K DIE,PRCHPPM D ES1
48 Q
49 ;
50EN ;SIGN 2237 IN PPM
51 D SIT Q:'$D(PRC("SITE")) D:'$D(PRCHNM) ES G:'$D(PRCHNM) Q
52 ;*81 Check site parameter to see if issue books should be allowed
53 I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1 D EN^PRCHG1
54 ;
55EN0 D:'$D(PRCHNM) ES G:'$D(PRCHNM) Q D TR G:'$D(DA) Q D PPM
56 G EN0
57 ;
58EN1 ;SIGN 2237 IN PC
59 D SIT Q:'$D(PRC("SITE"))
60EN10 D ST G:'$D(DA) Q S DR="[PRCHPC]",DIE("NO^")="" D ^DIE K DIE
61 G EN10
62 ;
63EN2 ;RETURN 2237 IN PC
64 D SIT Q:'$D(PRC("SITE"))
65EN20 ;D ST G:'$D(DA) Q S DR="[PRCHPCR]" D ^DIE K PRCHPCR S Z=$S($D(^PRCD(442.3,+$P(^PRC(443,DA,0),U,7),0)):$P(^(0),U,2),1:"") G:Z'=76 EN20
66 D ST G:'$D(DA) Q S DR="[PRCHPCR]" D ^DIE K PRCHPCR S Z=$P($G(^PRCD(442.3,+$P(^PRC(443,DA,0),U,7),0)),U,2) G:Z'=76 EN20
67 S $P(^PRC(443,DA,0),"^",2,4)="^^"
68 S PRCFA("WHO")=2 D RET
69 G EN20
70 ;
71EN3 ;SPLIT 2237 IN PPM
72 D SIT Q:'$D(PRC("SITE"))
73EN30 D TR G:'$D(DA) Q S PRCHSY(0)=Y(0),(PRCHPO,PRCHSY)=DA,(PRCHG,PRCHSZ)=1 D N^PRCHNPO3 G Q:'$D(PRCHSY)!('$O(^TMP($J,"PRCHS",0))),W1:+^TMP($J,"PRCHS",0)=+^PRCS(410,DA,10)
74 S PRCHSIT=+^TMP($J,"PRCHS",0),PRCHS=PRCHSY D WAIT^DICD,^PRCHSP I PRCHSY=-1 D ERR^PRCHNPO3,Q G EN30
75 W !!,"The new 2237, ",PRCHSX,", will now be printed with the old one." F DA=PRCHS,PRCHSY S PRCSF=1 D PRF1^PRCSP1
76 K PRCSF D Q
77 G EN30
78 ;
79EN4 ;EDIT A SIGNED 2237 IN PPM
80 D SIT Q:'$D(PRC("SITE"))
81EN40 D:'$D(PRCHNM) ES G:'$D(PRCHNM) Q S DIC("S")="I $P(^(0),U,3)]""""" D DIC G:'$D(DA) Q D PPM
82 G EN40
83 ;
84EN5 ;DISPLAY NO.OF REQUESTS TO BE PROCESSED BY PPM
85 S X=0 F I=0:0 S I=$O(^PRC(443,"AC",60,I)) Q:'I S X=X+1
86 W $C(7),!!!,?3,"There are "_X_" Requests ready to process." K X,I
87 Q
88 ;
89W1 W !!,"You have selected all Line Items, NO action taken.",$C(7) D Q
90 G EN3
91 ;
92STAT I $D(PRCFGPF) S DIC("S")="S Z=$P(^(0),U,2) I Z=10!(Z=60)!(Z=85)" Q
93 I $D(PRCHPCR) D Q
94 . S DIC("S")="I $P(^(0),U,2)=75!($P(^(0),U,2)=76)"
95 . I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 D Q
96 . . N PRC2237
97 . . S PRC2237=$P(^PRCS(410,DA,0),"^",1)
98 . . I '$$CHKDM^PRCVLIC(PRC2237) Q
99 . . I $O(^PRCS(410,"AG",PRC2237,""))]"" S DIC("S")="I $P(^(0),U,2)=75"
100 I '$D(PRCHPPM) S DIC("S")="I $P(^(0),U,2)>69" Q
101 K Z0 S (Z0(60),Z0(62),Z0(63),Z0(65),Z0(74))="" S:$P(^PRC(443,DA,0),U,10)=4 Z0(70)=""
102 S DIC("S")="I $D(Z0(+$P(^(0),U,2)))"
103 Q
Note: See TracBrowser for help on using the repository browser.