PRCFFU6 ;WISC/SJG-OBLIGATION PROCESSING UTILITIES ;4/27/94 2:46 PM
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
; No Top Level Entry
QUIT
COMP(REC442,REC410,FLAG) ; Compare values from 1358 SOE and 1358 SOM
; REC442 - IEN for original obligated 1358 from 442
; REC410 - IEN for adjusted unobligated 1358 from 410
; Get original values from 442
; FLAG = Return value for error check^increase/decrease condition
VAR ; Set up variables
K TMP442,TMP410 N LOOPX,CPFLAG,CCFLAG,BOCFLAG,ERFLAG,CHANGE
S (CPFLAG,CCFLAG,BOCFLAG,ERFLAG,CHANGE)=0
F LOOPX="BOC","DEL","DELSCH","FOB","PPT","VEND" S PRCFA(LOOPX)=""
F LOOPX="BOC","CC","FCP","VEND" S PRCFA("CHG",LOOPX)=""
N DA S DIC=442,DR="1;2;3;3.4;5",DA=+REC442,DIQ="TMP442(",DIQ(0)="IE" D EN^DIQ1 K DIC,DIQ,DR
N DA S DIC=410,DR="11;12;15;15.5;17;17.5",DA=+REC410,DIQ="TMP410(",DIQ(0)="IE" D EN^DIQ1 K DIC,DIQ,DR
VEN ; Compare Vendor
; Compare external vendor name on adjustment with external vendor name
; from 442
VEN1 I $G(TMP410(410,+REC410,12,"I"))'=$G(TMP442(442,+REC442,5,"I")) D G:PRCFA("VEND")=1 CP
.Q:$G(TMP442(442,+REC442,5,"I"))=""
.I $G(TMP410(410,+REC410,12,"I"))="" D
..Q:$G(TMP410(410,+REC410,11,"E"))=$G(TMP442(442,+REC442,5,"E"))
..K MSG W !
..S MSG(1)=" The vendor on this 1358 adjustment is missing!",MSG(1.5)=" "
..S MSG(2)=" Vendor on original 1358 obligation: "_$G(PRCTMP(410,$G(PRCTMP(442,+REC442,.07,"I")),11,"E"))
..S MSG(3)=" Vendor pointer on original 1358 obligation: "_$G(PRCTMP(410,$G(PRCTMP(442,+REC442,.07,"I")),12,"I")),MSG(3.5)=" "
..S MSG(4)=" Please have IRM correct the vendor on the 1358 adjustment before proceeding."
..D EN^DDIOL(.MSG) K MSG
..S PRCFA("VEND")=1,PRCFA("CHG","VEND")="VENDOR"
..Q
.Q
; Compare vendor pointer from adjustment with vendor pointer from 442
VEN2 I $G(PRCTMP(410,$G(PRCTMP(442,+REC442,.07,"I")),12,"I"))'=$G(TMP410(410,+REC410,12,"I")) D
.I $G(TMP410(410,+REC410,12,"I"))="" Q:$G(PRCTMP(410,$G(PRCTMP(442,+REC442,.07,"I")),11,"E"))=$G(TMP410(410,+REC410,11,"E"))
.S PRCFA("VEND")=1,PRCFA("CHG","VEND")="VENDOR"
.K MSG W !
.S MSG(1)=" The vendor pointer on this 1358 adjustment is different from the vendor"
.S MSG(2)=" pointer on the 442 record!"
.S MSG(2.5)=" "
.S MSG(3)=" Vendor name on obligation: "_$G(PRCTMP(410,$G(PRCTMP(442,+REC442,.07,"I")),12,"E"))
.S MSG(4)=" Vendor pointer: "_$G(PRCTMP(410,$G(PRCTMP(442,+REC442,.07,"I")),12,"I"))
.S MSG(4.5)=" "
.S MSG(5)=" Vendor name on adjustment: "_$G(TMP410(410,+REC410,12,"E"))
.S MSG(6)=" Vendor pointer: "_$G(TMP410(410,+REC410,12,"I"))
.S MSG(6.5)=" "
.S MSG(7)=" Please contact IRM for assistance!"
.D EN^DDIOL(.MSG) K MSG
.Q
CP ; Compare Control Point
I +$G(TMP410(410,+REC410,15,"I"))'=+$G(TMP442(442,+REC442,1,"I")) S CPFLAG=1,PRCFA("CHG","FCP")="FUND CONTROL POINT"
CC ; Compare Cost Center
I +$G(TMP410(410,+REC410,15.5,"I"))'=+$G(TMP442(442,+REC442,2,"I")) S CCFLAG=1,PRCFA("CHG","CC")="COST CENTER"
BOC ; Compare BOC
I +$G(TMP410(410,+REC410,17,"I"))'=+$G(TMP442(442,+REC442,3,"I")) S BOCFLAG=1,PRCFA("CHG","BOC")="BOC"
AMT ; Check for change in amounts
I $G(TMP410(410,+REC410,17.5,"I")) D
.I TMP410(410,+REC410,17.5,"I")>0 S IDFLAG="I"
.I TMP410(410,+REC410,17.5,"I")<0 S IDFLAG="D"
D
.I BOCFLAG S (CHANGE,ERFLAG)=1 Q
.I PRCFA("VEND") S (CHANGE,ERFLAG)=1 Q
.I CPFLAG S (CHANGE,ERFLAG)=1 Q
.I CCFLAG S (CHANGE,ERFLAG)=1 Q
.Q
QUIT ERFLAG_"^"_IDFLAG_"^"_CHANGE
UPDATE(REC442,REC410) ; Update Node 22 in File 442
S AMT=+$G(TMP410(410,+REC410,17.5,"I"))+$G(TMP442(442,+REC442,3.4,"I"))
S BOC=+$G(TMP442(442,+REC442,3,"I"))
N DA S DA(1)=REC442
S DIC="^PRC(442,"_DA(1)_",22,",DIC(0)="QEMZ",X=BOC D ^DIC
I Y>0 S DIE=DIC,DA=+Y,DR="1////^S X=AMT" D ^DIE
K DIC,DIE,DR,TMP410,TMP442,AMT,BOC
QUIT
AUTACC ; Update Ending Date and Auto Accrual Flag
Q:'$D(TMP("NEWDATE"))
N DATE,FLAG
S DATE=$P(TMP("NEWDATE"),U),FLAG=$P(TMP("NEWACC"),U)
S DIE=442,DA=POIEN,DR="29///^S X=DATE;30///^S X=FLAG" D ^DIE K DIE,DR,TMP("NEWACC"),TMP("NEWDATE")
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFFU6 4108 printed Sep 23, 2025@19:39:55 Page 2
PRCFFU6 ;WISC/SJG-OBLIGATION PROCESSING UTILITIES ;4/27/94 2:46 PM
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ; No Top Level Entry
+4 QUIT
COMP(REC442,REC410,FLAG) ; Compare values from 1358 SOE and 1358 SOM
+1 ; REC442 - IEN for original obligated 1358 from 442
+2 ; REC410 - IEN for adjusted unobligated 1358 from 410
+3 ; Get original values from 442
+4 ; FLAG = Return value for error check^increase/decrease condition
VAR ; Set up variables
+1 KILL TMP442,TMP410
NEW LOOPX,CPFLAG,CCFLAG,BOCFLAG,ERFLAG,CHANGE
+2 SET (CPFLAG,CCFLAG,BOCFLAG,ERFLAG,CHANGE)=0
+3 FOR LOOPX="BOC","DEL","DELSCH","FOB","PPT","VEND"
SET PRCFA(LOOPX)=""
+4 FOR LOOPX="BOC","CC","FCP","VEND"
SET PRCFA("CHG",LOOPX)=""
+5 NEW DA
SET DIC=442
SET DR="1;2;3;3.4;5"
SET DA=+REC442
SET DIQ="TMP442("
SET DIQ(0)="IE"
DO EN^DIQ1
KILL DIC,DIQ,DR
+6 NEW DA
SET DIC=410
SET DR="11;12;15;15.5;17;17.5"
SET DA=+REC410
SET DIQ="TMP410("
SET DIQ(0)="IE"
DO EN^DIQ1
KILL DIC,DIQ,DR
VEN ; Compare Vendor
+1 ; Compare external vendor name on adjustment with external vendor name
+2 ; from 442
VEN1 IF $GET(TMP410(410,+REC410,12,"I"))'=$GET(TMP442(442,+REC442,5,"I"))
Begin DoDot:1
+1 if $GET(TMP442(442,+REC442,5,"I"))=""
QUIT
+2 IF $GET(TMP410(410,+REC410,12,"I"))=""
Begin DoDot:2
+3 if $GET(TMP410(410,+REC410,11,"E"))=$GET(TMP442(442,+REC442,5,"E"))
QUIT
+4 KILL MSG
WRITE !
+5 SET MSG(1)=" The vendor on this 1358 adjustment is missing!"
SET MSG(1.5)=" "
+6 SET MSG(2)=" Vendor on original 1358 obligation: "_$GET(PRCTMP(410,$GET(PRCTMP(442,+REC442,.07,"I")),11,"E"))
+7 SET MSG(3)=" Vendor pointer on original 1358 obligation: "_$GET(PRCTMP(410,$GET(PRCTMP(442,+REC442,.07,"I")),12,"I"))
SET MSG(3.5)=" "
+8 SET MSG(4)=" Please have IRM correct the vendor on the 1358 adjustment before proceeding."
+9 DO EN^DDIOL(.MSG)
KILL MSG
+10 SET PRCFA("VEND")=1
SET PRCFA("CHG","VEND")="VENDOR"
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
if PRCFA("VEND")=1
GOTO CP
+13 ; Compare vendor pointer from adjustment with vendor pointer from 442
VEN2 IF $GET(PRCTMP(410,$GET(PRCTMP(442,+REC442,.07,"I")),12,"I"))'=$GET(TMP410(410,+REC410,12,"I"))
Begin DoDot:1
+1 IF $GET(TMP410(410,+REC410,12,"I"))=""
if $GET(PRCTMP(410,$GET(PRCTMP(442,+REC442,.07,"I")),11,"E"))=$GET(TMP410(410,+REC410,11,"E"))
QUIT
+2 SET PRCFA("VEND")=1
SET PRCFA("CHG","VEND")="VENDOR"
+3 KILL MSG
WRITE !
+4 SET MSG(1)=" The vendor pointer on this 1358 adjustment is different from the vendor"
+5 SET MSG(2)=" pointer on the 442 record!"
+6 SET MSG(2.5)=" "
+7 SET MSG(3)=" Vendor name on obligation: "_$GET(PRCTMP(410,$GET(PRCTMP(442,+REC442,.07,"I")),12,"E"))
+8 SET MSG(4)=" Vendor pointer: "_$GET(PRCTMP(410,$GET(PRCTMP(442,+REC442,.07,"I")),12,"I"))
+9 SET MSG(4.5)=" "
+10 SET MSG(5)=" Vendor name on adjustment: "_$GET(TMP410(410,+REC410,12,"E"))
+11 SET MSG(6)=" Vendor pointer: "_$GET(TMP410(410,+REC410,12,"I"))
+12 SET MSG(6.5)=" "
+13 SET MSG(7)=" Please contact IRM for assistance!"
+14 DO EN^DDIOL(.MSG)
KILL MSG
+15 QUIT
End DoDot:1
CP ; Compare Control Point
+1 IF +$GET(TMP410(410,+REC410,15,"I"))'=+$GET(TMP442(442,+REC442,1,"I"))
SET CPFLAG=1
SET PRCFA("CHG","FCP")="FUND CONTROL POINT"
CC ; Compare Cost Center
+1 IF +$GET(TMP410(410,+REC410,15.5,"I"))'=+$GET(TMP442(442,+REC442,2,"I"))
SET CCFLAG=1
SET PRCFA("CHG","CC")="COST CENTER"
BOC ; Compare BOC
+1 IF +$GET(TMP410(410,+REC410,17,"I"))'=+$GET(TMP442(442,+REC442,3,"I"))
SET BOCFLAG=1
SET PRCFA("CHG","BOC")="BOC"
AMT ; Check for change in amounts
+1 IF $GET(TMP410(410,+REC410,17.5,"I"))
Begin DoDot:1
+2 IF TMP410(410,+REC410,17.5,"I")>0
SET IDFLAG="I"
+3 IF TMP410(410,+REC410,17.5,"I")<0
SET IDFLAG="D"
End DoDot:1
+4 Begin DoDot:1
+5 IF BOCFLAG
SET (CHANGE,ERFLAG)=1
QUIT
+6 IF PRCFA("VEND")
SET (CHANGE,ERFLAG)=1
QUIT
+7 IF CPFLAG
SET (CHANGE,ERFLAG)=1
QUIT
+8 IF CCFLAG
SET (CHANGE,ERFLAG)=1
QUIT
+9 QUIT
End DoDot:1
+10 QUIT ERFLAG_"^"_IDFLAG_"^"_CHANGE
UPDATE(REC442,REC410) ; Update Node 22 in File 442
+1 SET AMT=+$GET(TMP410(410,+REC410,17.5,"I"))+$GET(TMP442(442,+REC442,3.4,"I"))
+2 SET BOC=+$GET(TMP442(442,+REC442,3,"I"))
+3 NEW DA
SET DA(1)=REC442
+4 SET DIC="^PRC(442,"_DA(1)_",22,"
SET DIC(0)="QEMZ"
SET X=BOC
DO ^DIC
+5 IF Y>0
SET DIE=DIC
SET DA=+Y
SET DR="1////^S X=AMT"
DO ^DIE
+6 KILL DIC,DIE,DR,TMP410,TMP442,AMT,BOC
+7 QUIT
AUTACC ; Update Ending Date and Auto Accrual Flag
+1 if '$DATA(TMP("NEWDATE"))
QUIT
+2 NEW DATE,FLAG
+3 SET DATE=$PIECE(TMP("NEWDATE"),U)
SET FLAG=$PIECE(TMP("NEWACC"),U)
+4 SET DIE=442
SET DA=POIEN
SET DR="29///^S X=DATE;30///^S X=FLAG"
DO ^DIE
KILL DIE,DR,TMP("NEWACC"),TMP("NEWDATE")
+5 QUIT
