PRCFFU15 ;WISC/SJG-1358 & PO OBLIGATION UTILITY, CONT ;8/15/94 17:47
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
; No top level entry
QUIT
;
VENCONO(IEN) ; Display vendor and contract information on org entry
; IEN - Internal entry number from 410
K PRCTMP N VENDOR
DISP S (VENDOR,CONT,CONTEND,VENCONT,CONTIEN)=""
D GENDIQ^PRCFFU7(410,IEN,"11;12;13;52","IEN","")
S VENDOR=$G(PRCTMP(410,IEN,11,"E"))
I VENDOR]"" W !,IOINLOW,"VENDOR: ",IOINHI,VENDOR,IOINORM,!
S CONT=$G(PRCTMP(410,IEN,13,"E")) Q:CONT=""
I CONT]"" D CONTNUM Q:CONTEND=""
I CONTEND]"" D
.W IOINLOW,"CONTRACT: ",IOINHI,CONT,IOINORM,!
.W IOINLOW,"CONTRACT ENDING DATE: ",IOINHI,CONTEND,IOINORM,!
Q
VENCONM(IEN) ; Display vendor and contract information on adjustment
; IEN - Internal entry number from 442
K PRCTMP N VENDOR,PRRQST
D GENDIQ^PRCFFU7(442,+PO,.07,"I","")
S PRRQST=$G(PRCTMP(442,+IEN,.07,"I"))
Q:PRRQST=""
I PRRQST]"" S POIEN=IEN,IEN=PRRQST D DISP
Q
POVENO(IEN) ; Display vendor and contract information
; IEN - Internal entry number from 442
K PRCTMP N VENNM,VENIEN
D GENDIQ^PRCFFU7(442,IEN,5,"IEN","")
S VENNM=$G(PRCTMP(442,IEN,5,"E")),VENIEN=$G(PRCTMP(442,IEN,5,"I"))
I VENNM]"" W !,"VENDOR: ",VENNM,!
I '$D(^PRC(442,+IEN,2,"AC")) W "CONTRACT: ** NONE ON THIS ORDER **",!
PO1 I $D(^PRC(442,+IEN,2,"AC")) D W !
.S (PRCFMOD,NEWADD)=0
.W ! K MSG S MSG(1)="One or more of the following contracts are associated with the line items"
.S MSG(2)="on this Purchase Order for Services for this Vendor: "
.D EN^DDIOL(.MSG) K MSG
.S CONT="" F S CONT=$O(^PRC(442,+IEN,2,"AC",CONT)) Q:CONT="" D ADDCONT
.K PRCFMOD,NEWADD
.Q
PO2 I $D(^PRC(443.6,+IEN,2,"AC")),$P(PRCFA("MOD"),U)="M" D W !
.S PRCFMOD=1,NEWADD=0
.W ! K MSG S MSG(1)="The Amendment has added line items which contain one or more of the following"
.S MSG(2)="contracts to this Purchase Order for Services:"
.D EN^DDIOL(.MSG) K MSG
.S CONT="" F S CONT=$O(^PRC(443.6,+IEN,2,"AC",CONT)) Q:CONT="" D ADDCONT
.D:NEWADD=0 EN^DDIOL(" ** NO NEW CONTRACTS ADDED THROUGH THE AMENDMENT **")
.K PRCFMOD,NEWADD
.Q
Q
ADDCONT ;
S DIC="^PRC(440,"_VENIEN_",4,",DIC(0)="MNZ",X=CONT D ^DIC K DIC Q:Y<0
I Y>0 D
.N DA,CONTIEN,CONTEND S CONTIEN=+Y
.S DIC=440,DR=6,DA=VENIEN,DIQ="PRCTMP(",DIQ(0)="IEN",DR(440.03)=".5;1",DA(440.03)=CONTIEN D EN^DIQ1 K DIC,DIQ,DR
.S CONTENDE=$G(PRCTMP(440.03,CONTIEN,1,"E")),CONTENDI=$G(PRCTMP(440.03,CONTIEN,1,"I"))
.I PRCFMOD=1 Q:$D(CONTENDA(9999999-CONTENDI)) S NEWADD=1
.S CONTENDA(9999999-CONTENDI)=CONTENDE_U_CONTENDI
.W !?2,"CONTRACT: ",CONT,?33,"END DATE: ",CONTENDE,?56,"START DATE: ",$G(PRCTMP(440.03,CONTIEN,.5,"E")) W:$G(PRCTMP(440.03,CONTIEN,.5,"E"))="" "NONE LISTED"
.Q
Q
MSG1 ; Display current auto accrual information for PO
K MSG W ! N FIL S FIL=$$FILE^PRCFFU16
S MSG(1)="CURRENT VALUES FOR AUTO ACCRUAL FOR P.O. SERVICE ORDER:"
S MSG(2)=" ENDING DATE FOR SERVICE: "_$G(PRCTMP(FIL,+OB,29,"E"))
S MSG(3)=" AUTO ACCRUAL FLAG: "_$G(PRCTMP(FIL,+OB,30,"E"))
D EN^DDIOL(.MSG) K MSG
Q
MSG2 ; Prompt for change if needed
N TAG S TAG=$$LABEL
K MSG W !! S MSG(1)="The Ending Date and the Auto Accrual Flag must now be entered for"
S MSG(2)="this obligation. The system will default to the Ending Date on the Vendor"
S MSG(3)="Contract from the "_TAG_", if available. Otherwise, the default Ending"
S MSG(4)="Date is the last date of the current month.",MSG(5)=" "
S MSG(6)="The Auto Accrual Flag tells FMS whether the "_TAG_" should be accrued."
S MSG(7)="The default value will be 'NO' if the Ending Date is within the same month."
S MSG(8)="To accrue the "_TAG_", change the flag to 'YES'."
D EN^DDIOL(.MSG) K MSG
Q
CONTNUM ; Determine contract number
I $G(PRCTMP(410,IEN,11,"E"))="" Q
I $G(PRCTMP(410,IEN,13,"I"))]"" D
.S VENID=$G(PRCTMP(410,IEN,12,"I")) Q:VENID=""
.S VENCONT=$G(PRCTMP(410,IEN,13,"I"))
.S DIC="^PRC(440,"_VENID_",4,",DIC(0)="MNZ",X=VENCONT D ^DIC K DIC
.Q:Y<0 I Y>0 D
..N DA S CONTIEN=+Y
..S DIC=440,DR=6,DA=+VENID,DIQ="PRCTMP(",DIQ(0)="IEN",DR(440.03)=".5;1",DA(440.03)=CONTIEN D EN^DIQ1 K DIC,DIQ,DR
..S CONTEND=$G(PRCTMP(440.03,CONTIEN,1,"E"))
..Q
.Q
Q
;
MSG5 ; Exit message
W ! D EN^DDIOL("Returning to Obligation processing...") W !
Q
LABEL() ; Determine label for messages
S LABEL=""
I '$D(PRCFA("MP")) S LABEL=""
I $D(TRNODE(0)) I $P(TRNODE(0),U,2)="O"!($P(TRNODE(0),U,2)="A") S LABEL="1358"
I $D(PRCFA("MP")),PRCFA("MP")=21 S LABEL="1358"
I $D(PRCFA("MP")),PRCFA("MP")=2 S LABEL="Purchase Order"
Q LABEL
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFFU15 4639 printed Sep 23, 2025@19:39:43 Page 2
PRCFFU15 ;WISC/SJG-1358 & PO OBLIGATION UTILITY, CONT ;8/15/94 17:47
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; No top level entry
+5 QUIT
+6 ;
VENCONO(IEN) ; Display vendor and contract information on org entry
+1 ; IEN - Internal entry number from 410
+2 KILL PRCTMP
NEW VENDOR
DISP SET (VENDOR,CONT,CONTEND,VENCONT,CONTIEN)=""
+1 DO GENDIQ^PRCFFU7(410,IEN,"11;12;13;52","IEN","")
+2 SET VENDOR=$GET(PRCTMP(410,IEN,11,"E"))
+3 IF VENDOR]""
WRITE !,IOINLOW,"VENDOR: ",IOINHI,VENDOR,IOINORM,!
+4 SET CONT=$GET(PRCTMP(410,IEN,13,"E"))
if CONT=""
QUIT
+5 IF CONT]""
DO CONTNUM
if CONTEND=""
QUIT
+6 IF CONTEND]""
Begin DoDot:1
+7 WRITE IOINLOW,"CONTRACT: ",IOINHI,CONT,IOINORM,!
+8 WRITE IOINLOW,"CONTRACT ENDING DATE: ",IOINHI,CONTEND,IOINORM,!
End DoDot:1
+9 QUIT
VENCONM(IEN) ; Display vendor and contract information on adjustment
+1 ; IEN - Internal entry number from 442
+2 KILL PRCTMP
NEW VENDOR,PRRQST
+3 DO GENDIQ^PRCFFU7(442,+PO,.07,"I","")
+4 SET PRRQST=$GET(PRCTMP(442,+IEN,.07,"I"))
+5 if PRRQST=""
QUIT
+6 IF PRRQST]""
SET POIEN=IEN
SET IEN=PRRQST
DO DISP
+7 QUIT
POVENO(IEN) ; Display vendor and contract information
+1 ; IEN - Internal entry number from 442
+2 KILL PRCTMP
NEW VENNM,VENIEN
+3 DO GENDIQ^PRCFFU7(442,IEN,5,"IEN","")
+4 SET VENNM=$GET(PRCTMP(442,IEN,5,"E"))
SET VENIEN=$GET(PRCTMP(442,IEN,5,"I"))
+5 IF VENNM]""
WRITE !,"VENDOR: ",VENNM,!
+6 IF '$DATA(^PRC(442,+IEN,2,"AC"))
WRITE "CONTRACT: ** NONE ON THIS ORDER **",!
PO1 IF $DATA(^PRC(442,+IEN,2,"AC"))
Begin DoDot:1
+1 SET (PRCFMOD,NEWADD)=0
+2 WRITE !
KILL MSG
SET MSG(1)="One or more of the following contracts are associated with the line items"
+3 SET MSG(2)="on this Purchase Order for Services for this Vendor: "
+4 DO EN^DDIOL(.MSG)
KILL MSG
+5 SET CONT=""
FOR
SET CONT=$ORDER(^PRC(442,+IEN,2,"AC",CONT))
if CONT=""
QUIT
DO ADDCONT
+6 KILL PRCFMOD,NEWADD
+7 QUIT
End DoDot:1
WRITE !
PO2 IF $DATA(^PRC(443.6,+IEN,2,"AC"))
IF $PIECE(PRCFA("MOD"),U)="M"
Begin DoDot:1
+1 SET PRCFMOD=1
SET NEWADD=0
+2 WRITE !
KILL MSG
SET MSG(1)="The Amendment has added line items which contain one or more of the following"
+3 SET MSG(2)="contracts to this Purchase Order for Services:"
+4 DO EN^DDIOL(.MSG)
KILL MSG
+5 SET CONT=""
FOR
SET CONT=$ORDER(^PRC(443.6,+IEN,2,"AC",CONT))
if CONT=""
QUIT
DO ADDCONT
+6 if NEWADD=0
DO EN^DDIOL(" ** NO NEW CONTRACTS ADDED THROUGH THE AMENDMENT **")
+7 KILL PRCFMOD,NEWADD
+8 QUIT
End DoDot:1
WRITE !
+9 QUIT
ADDCONT ;
+1 SET DIC="^PRC(440,"_VENIEN_",4,"
SET DIC(0)="MNZ"
SET X=CONT
DO ^DIC
KILL DIC
if Y<0
QUIT
+2 IF Y>0
Begin DoDot:1
+3 NEW DA,CONTIEN,CONTEND
SET CONTIEN=+Y
+4 SET DIC=440
SET DR=6
SET DA=VENIEN
SET DIQ="PRCTMP("
SET DIQ(0)="IEN"
SET DR(440.03)=".5;1"
SET DA(440.03)=CONTIEN
DO EN^DIQ1
KILL DIC,DIQ,DR
+5 SET CONTENDE=$GET(PRCTMP(440.03,CONTIEN,1,"E"))
SET CONTENDI=$GET(PRCTMP(440.03,CONTIEN,1,"I"))
+6 IF PRCFMOD=1
if $DATA(CONTENDA(9999999-CONTENDI))
QUIT
SET NEWADD=1
+7 SET CONTENDA(9999999-CONTENDI)=CONTENDE_U_CONTENDI
+8 WRITE !?2,"CONTRACT: ",CONT,?33,"END DATE: ",CONTENDE,?56,"START DATE: ",$GET(PRCTMP(440.03,CONTIEN,.5,"E"))
if $GET(PRCTMP(440.03,CONTIEN,.5,"E"))=""
WRITE "NONE LISTED"
+9 QUIT
End DoDot:1
+10 QUIT
MSG1 ; Display current auto accrual information for PO
+1 KILL MSG
WRITE !
NEW FIL
SET FIL=$$FILE^PRCFFU16
+2 SET MSG(1)="CURRENT VALUES FOR AUTO ACCRUAL FOR P.O. SERVICE ORDER:"
+3 SET MSG(2)=" ENDING DATE FOR SERVICE: "_$GET(PRCTMP(FIL,+OB,29,"E"))
+4 SET MSG(3)=" AUTO ACCRUAL FLAG: "_$GET(PRCTMP(FIL,+OB,30,"E"))
+5 DO EN^DDIOL(.MSG)
KILL MSG
+6 QUIT
MSG2 ; Prompt for change if needed
+1 NEW TAG
SET TAG=$$LABEL
+2 KILL MSG
WRITE !!
SET MSG(1)="The Ending Date and the Auto Accrual Flag must now be entered for"
+3 SET MSG(2)="this obligation. The system will default to the Ending Date on the Vendor"
+4 SET MSG(3)="Contract from the "_TAG_", if available. Otherwise, the default Ending"
+5 SET MSG(4)="Date is the last date of the current month."
SET MSG(5)=" "
+6 SET MSG(6)="The Auto Accrual Flag tells FMS whether the "_TAG_" should be accrued."
+7 SET MSG(7)="The default value will be 'NO' if the Ending Date is within the same month."
+8 SET MSG(8)="To accrue the "_TAG_", change the flag to 'YES'."
+9 DO EN^DDIOL(.MSG)
KILL MSG
+10 QUIT
CONTNUM ; Determine contract number
+1 IF $GET(PRCTMP(410,IEN,11,"E"))=""
QUIT
+2 IF $GET(PRCTMP(410,IEN,13,"I"))]""
Begin DoDot:1
+3 SET VENID=$GET(PRCTMP(410,IEN,12,"I"))
if VENID=""
QUIT
+4 SET VENCONT=$GET(PRCTMP(410,IEN,13,"I"))
+5 SET DIC="^PRC(440,"_VENID_",4,"
SET DIC(0)="MNZ"
SET X=VENCONT
DO ^DIC
KILL DIC
+6 if Y<0
QUIT
IF Y>0
Begin DoDot:2
+7 NEW DA
SET CONTIEN=+Y
+8 SET DIC=440
SET DR=6
SET DA=+VENID
SET DIQ="PRCTMP("
SET DIQ(0)="IEN"
SET DR(440.03)=".5;1"
SET DA(440.03)=CONTIEN
DO EN^DIQ1
KILL DIC,DIQ,DR
+9 SET CONTEND=$GET(PRCTMP(440.03,CONTIEN,1,"E"))
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
MSG5 ; Exit message
+1 WRITE !
DO EN^DDIOL("Returning to Obligation processing...")
WRITE !
+2 QUIT
LABEL() ; Determine label for messages
+1 SET LABEL=""
+2 IF '$DATA(PRCFA("MP"))
SET LABEL=""
+3 IF $DATA(TRNODE(0))
IF $PIECE(TRNODE(0),U,2)="O"!($PIECE(TRNODE(0),U,2)="A")
SET LABEL="1358"
+4 IF $DATA(PRCFA("MP"))
IF PRCFA("MP")=21
SET LABEL="1358"
+5 IF $DATA(PRCFA("MP"))
IF PRCFA("MP")=2
SET LABEL="Purchase Order"
+6 QUIT LABEL
