PRCHSWCH ;WISC/AKS-Check switches ;7/13/2001 08:00
;;5.1;IFCAP;**37,120**;Oct 20, 2000;Build 27
;Per VHA Directive 2004-038, this routine should not be modified.
Q
CHECK ;check switches
;
; processing is controlled by PRCHOBL
; PRCHOBL=0 do nothing PRCHOBL=1 obligate immediately without Fiscal
; PRCHOBL=2 call PRCOEDI to generate PHA transactions
I FILE'=442&(FILE'=443.6) W !,"Improper file." Q
; PRC*5.1*120 => AUTOOBLG switch (1=ON, 0=OFF) will control EDO Delivery
; and SITE/FCP All/Delivery switch auto obligating to
; insure the FCP UNOBL dollars are updated.
; EDIVEN switch (Y/N) will hold whether EDI vendor or not
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)
K PRCHOBL,AUTOOBLG
N PRCHFUND
S PRCHOBL=0,PRCHFUND=""
S PRCHFUND=$P(^PRC(FILE,PRCHPO,0),U,3) Q:PRCHFUND="" S PRCHFUND=+$P(PRCHFUND," ")
I $P($G(^PRC(442,PRCHPO,23)),U,11)="D" S PRCHOBL=1 D
. I $P($G(^PRC(420,PRC("SITE"),3)),U,2)="",$P($G(^PRC(420,PRC("SITE"),1,PRCHFUND,6)),U,2)="" S PRCHOBL=0
. I $P(^PRC(FILE,PRCHPO,0),U,2)=26 S PRCHOBL=1
I '$G(PRCHOBL) D
. 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
. 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
. 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
I '$G(PRCHOBL) D
. I $P($G(^PRC(420,PRC("SITE"),3)),U)="Y",EDICHK="Y" S PRCHOBL=1
. I $P($G(^PRC(420,PRC("SITE"),1,PRCHFUND,6)),U)="N" S PRCHOBL=0
; if a certified invoice, set flag to 0 so that Fiscal must process
I $P($G(^PRC(FILE,PRCHPO,0)),"^",2)=2 S PRCHOBL=0
;PRC*5.1*37, Added a missing check for EDI vendor at FCP level - ** Updated check via PRC*5.1*120 for EDI Delivery Order cancel
I PRCHOBL=1 D
. I $P($G(^PRC(442,PRCHPO,23)),U,11)="D" S AUTOOBLG=1
. I $P($G(^PRC(442,PRCHPO,0)),U,2)'=25 S AUTOOBLG=1
I $P($G(^PRC(442,PRCHPO,23)),U,11)="D"!($P($G(^PRC(442,PRCHPO,0)),U,2)'=25) I ($P($G(^PRC(420,PRC("SITE"),1,PRCHFUND,6)),U)="Y")!($P($G(^PRC(420,PRC("SITE"),3)),U)="Y"),EDICHK="Y" S PRCHOBL=1,AUTOOBLG=1
K FILE
QUIT
POST ;post init for PRC*5*113
N ZP,ZIP,CNTR
S ZP="" F S ZP=$O(^PRC(442,"F",25,ZP)) Q:ZP="" D
.S ZIP=$P($G(^PRC(442,+ZP,23)),"^",13) Q:ZIP="" Q:ZIP[";"
.S $P(^PRC(442,ZP,23),"^",13)=$P(^PRC(442,ZP,23),"^",13)_";PRCS(410.7,"
S ZP="" F S ZP=$O(^PRC(442,"F",25,ZP)) Q:ZP="" D CONV
S ZP="" F S ZP=$O(^PRC(442,"F",26,ZP)) Q:ZP="" D CONV
QUIT
CONV ;
Q:+$P($G(^PRC(442,ZP,1)),"^")=0
S DA=ZP,DIK(1)="5^D",DIK="^PRC(442," D EN^DIK
S VALUE=$P($G(^PRC(442,ZP,23)),"^",14) Q:+VALUE=0
S VVAL=$P($G(^PRC(440,VALUE,0)),"^") Q:VVAL=""
S VVAL=$E(VVAL,1,30) K ^PRC(442,"D",VVAL,ZP)
K DA,DIK,VALUE,VVAL
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHSWCH 2903 printed Sep 23, 2025@19:46:51 Page 2
PRCHSWCH ;WISC/AKS-Check switches ;7/13/2001 08:00
+1 ;;5.1;IFCAP;**37,120**;Oct 20, 2000;Build 27
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
CHECK ;check switches
+1 ;
+2 ; processing is controlled by PRCHOBL
+3 ; PRCHOBL=0 do nothing PRCHOBL=1 obligate immediately without Fiscal
+4 ; PRCHOBL=2 call PRCOEDI to generate PHA transactions
+5 IF FILE'=442&(FILE'=443.6)
WRITE !,"Improper file."
QUIT
+6 ; PRC*5.1*120 => AUTOOBLG switch (1=ON, 0=OFF) will control EDO Delivery
+7 ; and SITE/FCP All/Delivery switch auto obligating to
+8 ; insure the FCP UNOBL dollars are updated.
+9 ; EDIVEN switch (Y/N) will hold whether EDI vendor or not
+10 NEW EDICHK,EDIVEN
SET EDICHK="N"
SET EDIVEN=$PIECE($GET(^PRC(FILE,PRCHPO,1)),U)
if EDIVEN'=""
SET EDICHK=$PIECE($GET(^PRC(440,EDIVEN,3)),U,2)
+11 KILL PRCHOBL,AUTOOBLG
+12 NEW PRCHFUND
+13 SET PRCHOBL=0
SET PRCHFUND=""
+14 SET PRCHFUND=$PIECE(^PRC(FILE,PRCHPO,0),U,3)
if PRCHFUND=""
QUIT
SET PRCHFUND=+$PIECE(PRCHFUND," ")
+15 IF $PIECE($GET(^PRC(442,PRCHPO,23)),U,11)="D"
SET PRCHOBL=1
Begin DoDot:1
+16 IF $PIECE($GET(^PRC(420,PRC("SITE"),3)),U,2)=""
IF $PIECE($GET(^PRC(420,PRC("SITE"),1,PRCHFUND,6)),U,2)=""
SET PRCHOBL=0
+17 IF $PIECE(^PRC(FILE,PRCHPO,0),U,2)=26
SET PRCHOBL=1
End DoDot:1
+18 IF '$GET(PRCHOBL)
Begin DoDot:1
+19 IF $PIECE($GET(^PRC(420,PRC("SITE"),3)),U,2)="A"
IF $PIECE($GET(^PRC(420,PRC("SITE"),1,PRCHFUND,6)),U,2)'="D"
SET PRCHOBL=1
+20 IF $PIECE($GET(^PRC(420,PRC("SITE"),3)),U,2)="D"
IF $PIECE($GET(^PRC(420,PRC("SITE"),1,PRCHFUND,6)),U,2)="A"
SET PRCHOBL=1
+21 IF $PIECE($GET(^PRC(420,PRC("SITE"),3)),U,2)=""
IF $PIECE($GET(^PRC(420,PRC("SITE"),1,PRCHFUND,6)),U,2)="A"
SET PRCHOBL=1
End DoDot:1
+22 IF '$GET(PRCHOBL)
Begin DoDot:1
+23 IF $PIECE($GET(^PRC(420,PRC("SITE"),3)),U)="Y"
IF EDICHK="Y"
SET PRCHOBL=1
+24 IF $PIECE($GET(^PRC(420,PRC("SITE"),1,PRCHFUND,6)),U)="N"
SET PRCHOBL=0
End DoDot:1
+25 ; if a certified invoice, set flag to 0 so that Fiscal must process
+26 IF $PIECE($GET(^PRC(FILE,PRCHPO,0)),"^",2)=2
SET PRCHOBL=0
+27 ;PRC*5.1*37, Added a missing check for EDI vendor at FCP level - ** Updated check via PRC*5.1*120 for EDI Delivery Order cancel
+28 IF PRCHOBL=1
Begin DoDot:1
+29 IF $PIECE($GET(^PRC(442,PRCHPO,23)),U,11)="D"
SET AUTOOBLG=1
+30 IF $PIECE($GET(^PRC(442,PRCHPO,0)),U,2)'=25
SET AUTOOBLG=1
End DoDot:1
+31 IF $PIECE($GET(^PRC(442,PRCHPO,23)),U,11)="D"!($PIECE($GET(^PRC(442,PRCHPO,0)),U,2)'=25)
IF ($PIECE($GET(^PRC(420,PRC("SITE"),1,PRCHFUND,6)),U)="Y")!($PIECE($GET(^PRC(420,PRC("SITE"),3)),U)="Y")
IF EDICHK="Y"
SET PRCHOBL=1
SET AUTOOBLG=1
+32 KILL FILE
+33 QUIT
POST ;post init for PRC*5*113
+1 NEW ZP,ZIP,CNTR
+2 SET ZP=""
FOR
SET ZP=$ORDER(^PRC(442,"F",25,ZP))
if ZP=""
QUIT
Begin DoDot:1
+3 SET ZIP=$PIECE($GET(^PRC(442,+ZP,23)),"^",13)
if ZIP=""
QUIT
if ZIP[";"
QUIT
+4 SET $PIECE(^PRC(442,ZP,23),"^",13)=$PIECE(^PRC(442,ZP,23),"^",13)_";PRCS(410.7,"
End DoDot:1
+5 SET ZP=""
FOR
SET ZP=$ORDER(^PRC(442,"F",25,ZP))
if ZP=""
QUIT
DO CONV
+6 SET ZP=""
FOR
SET ZP=$ORDER(^PRC(442,"F",26,ZP))
if ZP=""
QUIT
DO CONV
+7 QUIT
CONV ;
+1 if +$PIECE($GET(^PRC(442,ZP,1)),"^")=0
QUIT
+2 SET DA=ZP
SET DIK(1)="5^D"
SET DIK="^PRC(442,"
DO EN^DIK
+3 SET VALUE=$PIECE($GET(^PRC(442,ZP,23)),"^",14)
if +VALUE=0
QUIT
+4 SET VVAL=$PIECE($GET(^PRC(440,VALUE,0)),"^")
if VVAL=""
QUIT
+5 SET VVAL=$EXTRACT(VVAL,1,30)
KILL ^PRC(442,"D",VVAL,ZP)
+6 KILL DA,DIK,VALUE,VVAL
+7 QUIT
