source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFGPF.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 2.2 KB
Line 
1PRCFGPF ;SF-ISC/TKW,WISC/DGL-PROCESS GENERAL POST FUNDS 2237 REQUEST IN FISCAL ; [6/26/98 11:05am]
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4EN S PRCF("X")="SP" D ^PRCFSITE Q:'% S PRCFGPF=1
5 ; ALLOW SELECTION ONLY OF GPF TRANSACTIONS WITH SUPPLY STATUS='FISCAL ACTION REQUIRED'
6EN0 D:'$D(MESSAGE) ES Q:'$D(MESSAGE) S PRCFDICS=" I $O(^PRCD(442.3,""C"",+$P(^PRC(443,Y,0),U,7),0))=10" D TR^PRCHG G:'$D(DA) Q
7 S DIE="^PRC(443,",DR=1.5 D ^DIE K DIE,DR
8 S PRCFG=$S($D(^PRCD(442.3,+$P(^PRC(443,DA,0),U,7),0)):$P(^(0),U,2),1:"") D REMOVE^PRCHES11(DA) S P=+PRC("PER")
9 G:PRCFG=10 EN0
10 ;IF RETURNED TO SERVICE
11 I PRCFG=85 D RTS G EN0
12 ;IF APPROVED, AFFIX FISCAL SIGNATURE AND PRINT 2237 IN SUPPLY.
13 S MESSAGE=""
14 D ENCODE^PRCSC3(DA,DUZ,.MESSAGE)
15 I MESSAGE<0 W !,"Electronic Signature failure: ",MESSAGE G Q
16 S PRCHQ=$P(^PRCS(410,DA,0),U,4),D0=DA,PRCHQ=$S(PRCHQ=5:"DQ^PRCPRIB0",1:"QUE^PRCSP12"),PRCHQ("DEST")="S" D ^PRCHQUE G EN0
17ES G Q:'$D(PRC("PER"))!('$D(PRC("SITE")))
18 S MESSAGE=""
19 D ESIG^PRCUESIG(DUZ,.MESSAGE)
20 G Q:MESSAGE'=1
21 Q
22Q K %,DA,DIC,DIE,DR,MESSAGE,P,PRC,PRCF,PRCFDICS,PRCFGPF,PRCFG,PRCHNM,PRCHQ Q
23RTS ;UPDATE COMMITTED CP BALANCE, REMOVE CP OFFICIAL SIGNATURE, ALLOW FISCAL TO ENTER COMMENTS, UPDATE QTY.DUE-IN IF SERVICE RUNNING INVENTORY, SEND BULLETIN
24 S X=+$P($G(^PRCS(410,DA,4)),"^",8)
25 D TRANK^PRCSES,REMOVE^PRCSC1(DA),REMOVE^PRCSC3(DA)
26 S $P(^PRCS(410,DA,10),U,4)=$P(^PRC(443,DA,0),U,7),DIE="^PRCS(410,",DR=61
27 D ^DIE K DIE D EN3^PRCPWI
28 S XMB="PRCH GPF"
29 S XMB(1)=$P(^PRCS(410,DA,0),U,4),XMB(1)=$S($P(^PRCS(410.5,XMB(1),0),U)'["1358":"2237",1:"2237")
30 S XMB(2)="FISCAL",XMB(3)=$P(^PRCS(410,DA,0),U,1)
31 S XMB(4)=$P(^PRCS(410,DA,4),U,1),XMB(5)=$P(XMB(3),"-",4)
32 K ^TMP("PRCFGPF",$J)
33 S XMTEXT="^TMP(""PRCFGPF"",$J,",XX=0,X=1,^TMP("PRCFGPF",$J,X)=" Purpose: "
34 F S XX=$O(^PRCS(410,DA,8,XX)) Q:XX="" S X=X+1,^TMP("PRCFGPF",$J,X)=$G(^PRCS(410,DA,8,XX,0))
35 S XX=0,X=X+1,^TMP("PRCFGPF",$J,X)=""
36 S X=X+1,^TMP("PRCFGPF",$J,X)=" Reason for return: "
37 F S XX=$O(^PRCS(410,DA,13,XX)) Q:XX="" S X=X+1,^TMP("PRCFGPF",$J,X)=$G(^PRCS(410,DA,13,XX,0))
38 S X="" K XMY
39 F I=0:0 S X=$O(^PRC(420,PRC("SITE"),1,XMB(5),1,X)) Q:X="" D
40 . S A=$G(^(X,0))
41 . I $P(A,U,3)="Y" S XMY(X)=""
42 . Q
43 D ^XMB K ^TMP("PRCFGPF",$J)
44 Q
Note: See TracBrowser for help on using the repository browser.