PRCUFCU ;WISC/SJG-OBLIGATION CONVERSION UTILITIES ;7/25/94 11:25
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
QUIT
; No top level entry
BOCS ; Step 1 - Assign BOCs to Supply Fund Line Items
N SUBINFO,LOOP2,ITEMNO,ACCT,ITEMBOC
S LOOP2=0
F S LOOP2=$O(^PRC(442,LOOP,2,LOOP2)) Q:LOOP2'>0 D
.K PRCTMP(442.01)
.S SUBINFO="442.01^1.5;3.5;9.5^"_LOOP2
.D GENDIQ^PRCFFU7(442,LOOP,40,"IE",SUBINFO)
.S ITEMBOC=+$G(PRCTMP(442.01,LOOP2,3.5,"I"))
.I ITEMBOC>0 Q
.S ITEMNO=+$G(PRCTMP(442.01,LOOP2,1.5,"I"))
.S ACCT=$$ACCT^PRCPUX1($E($$NSN^PRCPUX1(ITEMNO),1,4))
.S ITEMBOC=$S(ACCT=1:2697,ACCT=2:2698,ACCT=3:2699,ACCT=6:2699,ACCT=8:2696,1:2699)
.S ITEMBOC=$P($G(^PRCD(420.2,ITEMBOC,0)),U)
.S DA(1)=LOOP,DA=LOOP2,DIE="^PRC(442,"_DA(1)_",2,"
.S DR="3.5////^S X=ITEMBOC" D ^DIE K DIE,DR,DA,X
.Q
K PRCTMP(442.01)
QUIT
BOCG ; Step 1 - Assign BOCS to General Post Fund Line Items
N SUBINFO,LOOP2,ITEMNO,ITEMBOC
S LOOP2=0,FATAL=0
F S LOOP2=$O(^PRC(442,LOOP,2,LOOP2)) Q:LOOP2'>0 D
.K PRCTMP(442.01)
.S SUBINFO="442.01^1.5;3.5;9.5^"_LOOP2
.D GENDIQ^PRCFFU7(442,LOOP,40,"IE",SUBINFO)
.S ITEMBOC=+$G(PRCTMP(442.01,LOOP2,3.5,"I"))
.I ITEMBOC>0 Q
.S ITEMNO=+$G(PRCTMP(442.01,LOOP2,1.5,"I"))
.I ITEMNO>0 D
..K PRCTMP(441,ITEMNO,12)
..D GENDIQ^PRCFFU7(441,ITEMNO,12,"IE","")
..S ITEMBOC=+$G(PRCTMP(441,ITEMNO,12,"I"))
..I ITEMBOC=0 S ITEMBOC=9999
..Q
.I ITEMNO=0 S ITEMBOC=9999
.S ITEMBOC=$P($G(^PRCD(420.2,ITEMBOC,0)),U)
.S DA(1)=LOOP,DA=LOOP2,DIE="^PRC(442,"_DA(1)_",2,"
.S DR="3.5////^S X=ITEMBOC" D ^DIE K DIE,DR,DA,X
.K PRCTMP(441,ITEMNO,12)
.Q
K PRCTMP(442.01)
QUIT
AMTS ; Set variables for Total Amount, Net Amount, Liquidated Amount
S PRCFA("GROSS")=$G(PRCTMP(442,LOOP,91,"E"))
S PRCFA("NET")=$G(PRCTMP(442,LOOP,92,"E"))
S PRCFA("LIQ")=+$G(PRCTMP(442,LOOP,93,"E"))
S FATAL=0
I PRCFA("GROSS")-PRCFA("LIQ")=0 S FATAL=1 Q
I PRCFA("NET")-PRCFA("LIQ")=0 S FATAL=1 Q
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCUFCU 2004 printed Nov 22, 2024@17:29:49 Page 2
PRCUFCU ;WISC/SJG-OBLIGATION CONVERSION UTILITIES ;7/25/94 11:25
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 QUIT
+5 ; No top level entry
BOCS ; Step 1 - Assign BOCs to Supply Fund Line Items
+1 NEW SUBINFO,LOOP2,ITEMNO,ACCT,ITEMBOC
+2 SET LOOP2=0
+3 FOR
SET LOOP2=$ORDER(^PRC(442,LOOP,2,LOOP2))
if LOOP2'>0
QUIT
Begin DoDot:1
+4 KILL PRCTMP(442.01)
+5 SET SUBINFO="442.01^1.5;3.5;9.5^"_LOOP2
+6 DO GENDIQ^PRCFFU7(442,LOOP,40,"IE",SUBINFO)
+7 SET ITEMBOC=+$GET(PRCTMP(442.01,LOOP2,3.5,"I"))
+8 IF ITEMBOC>0
QUIT
+9 SET ITEMNO=+$GET(PRCTMP(442.01,LOOP2,1.5,"I"))
+10 SET ACCT=$$ACCT^PRCPUX1($EXTRACT($$NSN^PRCPUX1(ITEMNO),1,4))
+11 SET ITEMBOC=$SELECT(ACCT=1:2697,ACCT=2:2698,ACCT=3:2699,ACCT=6:2699,ACCT=8:2696,1:2699)
+12 SET ITEMBOC=$PIECE($GET(^PRCD(420.2,ITEMBOC,0)),U)
+13 SET DA(1)=LOOP
SET DA=LOOP2
SET DIE="^PRC(442,"_DA(1)_",2,"
+14 SET DR="3.5////^S X=ITEMBOC"
DO ^DIE
KILL DIE,DR,DA,X
+15 QUIT
End DoDot:1
+16 KILL PRCTMP(442.01)
+17 QUIT
BOCG ; Step 1 - Assign BOCS to General Post Fund Line Items
+1 NEW SUBINFO,LOOP2,ITEMNO,ITEMBOC
+2 SET LOOP2=0
SET FATAL=0
+3 FOR
SET LOOP2=$ORDER(^PRC(442,LOOP,2,LOOP2))
if LOOP2'>0
QUIT
Begin DoDot:1
+4 KILL PRCTMP(442.01)
+5 SET SUBINFO="442.01^1.5;3.5;9.5^"_LOOP2
+6 DO GENDIQ^PRCFFU7(442,LOOP,40,"IE",SUBINFO)
+7 SET ITEMBOC=+$GET(PRCTMP(442.01,LOOP2,3.5,"I"))
+8 IF ITEMBOC>0
QUIT
+9 SET ITEMNO=+$GET(PRCTMP(442.01,LOOP2,1.5,"I"))
+10 IF ITEMNO>0
Begin DoDot:2
+11 KILL PRCTMP(441,ITEMNO,12)
+12 DO GENDIQ^PRCFFU7(441,ITEMNO,12,"IE","")
+13 SET ITEMBOC=+$GET(PRCTMP(441,ITEMNO,12,"I"))
+14 IF ITEMBOC=0
SET ITEMBOC=9999
+15 QUIT
End DoDot:2
+16 IF ITEMNO=0
SET ITEMBOC=9999
+17 SET ITEMBOC=$PIECE($GET(^PRCD(420.2,ITEMBOC,0)),U)
+18 SET DA(1)=LOOP
SET DA=LOOP2
SET DIE="^PRC(442,"_DA(1)_",2,"
+19 SET DR="3.5////^S X=ITEMBOC"
DO ^DIE
KILL DIE,DR,DA,X
+20 KILL PRCTMP(441,ITEMNO,12)
+21 QUIT
End DoDot:1
+22 KILL PRCTMP(442.01)
+23 QUIT
AMTS ; Set variables for Total Amount, Net Amount, Liquidated Amount
+1 SET PRCFA("GROSS")=$GET(PRCTMP(442,LOOP,91,"E"))
+2 SET PRCFA("NET")=$GET(PRCTMP(442,LOOP,92,"E"))
+3 SET PRCFA("LIQ")=+$GET(PRCTMP(442,LOOP,93,"E"))
+4 SET FATAL=0
+5 IF PRCFA("GROSS")-PRCFA("LIQ")=0
SET FATAL=1
QUIT
+6 IF PRCFA("NET")-PRCFA("LIQ")=0
SET FATAL=1
QUIT
+7 QUIT
