- 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 Jan 18, 2025@03:11:58 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