| [613] | 1 | PRCHSWCH ;WISC/AKS-Check switches ;7/13/2001 08:00
|
|---|
| 2 | ;;5.1;IFCAP;**37**;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | Q
|
|---|
| 5 | CHECK ;check switches
|
|---|
| 6 | ;
|
|---|
| 7 | ; processing is controlled by PRCHOBL
|
|---|
| 8 | ; PRCHOBL=0 do nothing PRCHOBL=1 obligate immediately without Fiscal
|
|---|
| 9 | ; PRCHOBL=2 call PRCOEDI to generate PHA transactions
|
|---|
| 10 | I FILE'=442&(FILE'=443.6) W !,"Improper file." Q
|
|---|
| 11 | N EDICHK,EDIVEN S EDICHK="N",EDIVEN=$P($G(^PRC(FILE,PRCHPO,1)),U) S:EDIVEN'="" EDICHK=$P($G(^PRC(440,EDIVEN,3)),U,2)
|
|---|
| 12 | K PRCHOBL
|
|---|
| 13 | N PRCHFUND
|
|---|
| 14 | S PRCHOBL=0,PRCHFUND=""
|
|---|
| 15 | S PRCHFUND=$P(^PRC(FILE,PRCHPO,0),U,3) Q:PRCHFUND="" S PRCHFUND=+$P(PRCHFUND," ")
|
|---|
| 16 | I $P($G(^PRC(442,PRCHPO,23)),U,11)="D" S PRCHOBL=1 D
|
|---|
| 17 | . I $P($G(^PRC(420,PRC("SITE"),3)),U,2)="",$P($G(^PRC(420,PRC("SITE"),1,PRCHFUND,6)),U,2)="" S PRCHOBL=0
|
|---|
| 18 | . I $P(^PRC(FILE,PRCHPO,0),U,2)=26 S PRCHOBL=1
|
|---|
| 19 | I '$G(PRCHOBL) D
|
|---|
| 20 | . I $P($G(^PRC(420,PRC("SITE"),3)),U,2)="A",$P($G(^PRC(420,PRC("SITE"),1,PRCHFUND,6)),U,2)'="D" S PRCHOBL=1
|
|---|
| 21 | . I $P($G(^PRC(420,PRC("SITE"),3)),U,2)="D",$P($G(^PRC(420,PRC("SITE"),1,PRCHFUND,6)),U,2)="A" S PRCHOBL=1
|
|---|
| 22 | . I $P($G(^PRC(420,PRC("SITE"),3)),U,2)="",$P($G(^PRC(420,PRC("SITE"),1,PRCHFUND,6)),U,2)="A" S PRCHOBL=1
|
|---|
| 23 | I '$G(PRCHOBL) D
|
|---|
| 24 | . I $P($G(^PRC(420,PRC("SITE"),3)),U)="Y",EDICHK="Y" S PRCHOBL=1
|
|---|
| 25 | . I $P($G(^PRC(420,PRC("SITE"),1,PRCHFUND,6)),U)="N" S PRCHOBL=0
|
|---|
| 26 | . ; PRC*5.1*37, Added a missing check for EDI vendor at FCP level
|
|---|
| 27 | . I $P($G(^PRC(420,PRC("SITE"),1,PRCHFUND,6)),U)="Y",EDICHK="Y" S PRCHOBL=1
|
|---|
| 28 | ; if a certified invoice, set flag to 0 so that Fiscal must process
|
|---|
| 29 | I $P($G(^PRC(FILE,PRCHPO,0)),"^",2)=2 S PRCHOBL=0
|
|---|
| 30 | K FILE
|
|---|
| 31 | QUIT
|
|---|
| 32 | POST ;post init for PRC*5*113
|
|---|
| 33 | N ZP,ZIP,CNTR
|
|---|
| 34 | S ZP="" F S ZP=$O(^PRC(442,"F",25,ZP)) Q:ZP="" D
|
|---|
| 35 | .S ZIP=$P($G(^PRC(442,+ZP,23)),"^",13) Q:ZIP="" Q:ZIP[";"
|
|---|
| 36 | .S $P(^PRC(442,ZP,23),"^",13)=$P(^PRC(442,ZP,23),"^",13)_";PRCS(410.7,"
|
|---|
| 37 | S ZP="" F S ZP=$O(^PRC(442,"F",25,ZP)) Q:ZP="" D CONV
|
|---|
| 38 | S ZP="" F S ZP=$O(^PRC(442,"F",26,ZP)) Q:ZP="" D CONV
|
|---|
| 39 | QUIT
|
|---|
| 40 | CONV ;
|
|---|
| 41 | Q:+$P($G(^PRC(442,ZP,1)),"^")=0
|
|---|
| 42 | S DA=ZP,DIK(1)="5^D",DIK="^PRC(442," D EN^DIK
|
|---|
| 43 | S VALUE=$P($G(^PRC(442,ZP,23)),"^",14) Q:+VALUE=0
|
|---|
| 44 | S VVAL=$P($G(^PRC(440,VALUE,0)),"^") Q:VVAL=""
|
|---|
| 45 | S VVAL=$E(VVAL,1,30) K ^PRC(442,"D",VVAL,ZP)
|
|---|
| 46 | K DA,DIK,VALUE,VVAL
|
|---|
| 47 | QUIT
|
|---|
