PRCFFU15.m

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 ---PRCFFU15   4639     printed  Feb 18, 2025@23:30:02                                                                                                                                                                                                    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