PRCUFCU1 ;WISC/SJG-OBLIGATION CONVERSION UTILITIES CONT ;7/6/94 14:57
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
QUIT
; No top level entry
DET ; Step 3 - Determine total amts on FMS lines
; Set in array PRCFA("BOCTOT")
N LOOP3,LOOP4 S LOOP3=0
F S LOOP3=$O(^PRC(442,LOOP,22,"B",LOOP3)) Q:LOOP3=""!(LOOP3'>0) D
.S LOOP4=0 F S LOOP4=$O(^PRC(442,LOOP,22,"B",LOOP3,LOOP4)) Q:LOOP4=""!(LOOP4'>0) D
..S NODET=^PRC(442,LOOP,22,LOOP4,0)
..S BOC=$P(NODET,U),AMTTOT=$P(NODET,U,2),FMSLIN=$P(NODET,U,3)
..I FMSLIN=991&(AMTTOT=0) Q
..S PRCFA("BOCTOT",BOC,FMSLIN)=BOC_U_AMTTOT_U_FMSLIN_U_"I"
..K NODET,BOC,AMTTOT,FMSLIN
..Q
.Q
QUIT
RECD ; Step 4 - Calculate receiving line BOCS for FMS lines
; Set in array PRCFA("BOCREC")
N LINE S LINE=0,PRCFA("LIQ")=0
F S LINE=$O(^PRC(442,LOOP,2,LINE)) Q:LINE=""!(LINE'>0) D
.S PRCFA("TEMP")=^(LINE,0)
.S BOC=+$P(PRCFA("TEMP"),U,4)
.I '$D(PRCFA("BOCREC",BOC)) S PRCFA("BOCREC",BOC)=BOC,$P(PRCFA("BOCREC",BOC),U,2)=0
.I $D(^PRC(442,LOOP,2,LINE,3)) D
..K PRCFA("TEMP") S PRCFA("RECLINE")=0
..S RECLINE=0 F S RECLINE=$O(^PRC(442,LOOP,2,LINE,3,RECLINE)) Q:RECLINE=""!(RECLINE'>0) D
...S PRCFA("REC")=^(RECLINE,0)
...S RECAMT=$P(PRCFA("REC"),U,3)
...S PRCFA("RECLINE")=PRCFA("RECLINE")+RECAMT
...Q
..S TOTREC=$P(PRCFA("BOCREC",BOC),U,2),TOTREC=TOTREC+PRCFA("RECLINE")
..S $P(PRCFA("BOCREC",BOC),U,2)=TOTREC
..S PRCFA("LIQ")=PRCFA("LIQ")+PRCFA("RECLINE")
..K PRCFA("REC"),PRCFA("RECLINE"),RECAMT,BOC,TOTREC
..Q
.K PRCFA("TEMP")
.Q
D ESH,SETA,SETB
KILL RECAMT,RECLINE,LINE,BOC
QUIT
ESH ; Estimated shipping/handling
N ESHAMT,ESHBOC,ESHLIN
D GENDIQ^PRCFFU7(442,LOOP,"13:13.05","IE","")
S ESHAMT=$G(PRCTMP(442,LOOP,13,"I"))
I ESHAMT]"" D Q
.N AMTREC
.S ESHBOC=+$G(PRCTMP(442,LOOP,13.05,"I"))
.I $P(PRCFA("MOD"),U)="M" S PRCFA("BOCREC",ESHBOC,991)=ESHBOC_U_ESHAMT
.I $P(PRCFA("MOD"),U)="E" S PRCFA("BOCREC",ESHBOC,991)=ESHBOC_U_"0"
.S PRCFA("LIQ")=PRCFA("LIQ")+ESHAMT
.S PRCFA("BOCREC","ESH")=ESHBOC_U_ESHAMT_"^991^I"
.Q
SETA ;
N LOOP5,LINE S LOOP5=0
F S LOOP5=$O(PRCFA("BOCTOT",LOOP5)) Q:LOOP5=""!(LOOP5'>0) D
.S LINE=0
.S LINE=$O(PRCFA("BOCTOT",LOOP5,LINE))
.S PRCFA("BOC",LOOP5,LINE)=LOOP5_U_U_LINE_U_"I"
.Q
QUIT
SETB ;
N LOOP5,LINE S LOOP5=0
F S LOOP5=$O(PRCFA("BOCTOT",LOOP5)) Q:LOOP5=""!(LOOP5'>0) D
.S LINE=0
.S LINE=$O(PRCFA("BOCTOT",LOOP5,LINE))
.Q:LINE=991
.S PRCFA("BOCREC",LOOP5,LINE)=PRCFA("BOCREC",LOOP5)
.Q
QUIT
CALC ; Step 5 - Calculate amts not yet received to be sent to FMS
; Set into array PRCFA("BOC")
N ESHAMT,ESHBOC,ESHLIN
I $D(PRCFA("BOCREC","ESH")) D
.S ESHBOC=$P(PRCFA("BOCREC","ESH"),U),ESHAMT=$P(PRCFA("BOCREC","ESH"),U,2),ESHLIN=$P(PRCFA("BOCREC","ESH"),U,3)
.Q
N LOOP6 S LOOP6=0,PRCFCHG("BOC","TOT")=0
F S LOOP6=$O(PRCFA("BOCTOT",LOOP6)) Q:LOOP6=""!(LOOP6'>0) D
.S LOOP7=0
.F S LOOP7=$O(PRCFA("BOCTOT",LOOP6,LOOP7)) Q:LOOP7=""!(LOOP7'>0) D
..S TOTAMT=$P(PRCFA("BOCTOT",LOOP6,LOOP7),U,2)
..S RECAMT=$P(PRCFA("BOCREC",LOOP6,LOOP7),U,2)
..S FMSAMT=TOTAMT-RECAMT
..I FMSAMT>0 D
...I $D(PRCFA("BOCREC","ESH")) I (ESHBOC=LOOP6)&(ESHAMT=RECAMT)&(ESHLIN=LOOP7) Q
...S PRCFCHG("BOC",LOOP6,LOOP7)=LOOP6_U_FMSAMT_U_LOOP7_"^I"
...S PRCFCHG("BOC","TOT")=PRCFCHG("BOC","TOT")+FMSAMT
...S $P(PRCFA("BOC",LOOP6,LOOP7),U,2)=FMSAMT
..Q
S TOTAMT=PRCFCHG("BOC","TOT")
D CLEAN
KILL LOOP7,FMSAMT,RECAMT
QUIT
CLEAN ; Clean up arrays
I $D(PRCFA("BOCREC","ESH")),$P(PRCFA("MOD"),U)="M" D
.N ESHBOC,ESHLIN
.S ESHBOC=$P(PRCFA("BOCREC","ESH"),U)
.S ESHLIN=$P(PRCFA("BOCREC","ESH"),U,3)
.K PRCFA("BOCTOT",ESHBOC,ESHLIN)
.K PRCFA("BOC",ESHBOC,ESHLIN)
.K PRCFA("BOCREC",ESHBOC,ESHLIN)
.K PRCFA("BOCREC","ESH")
.Q
N LOOP8,LOOP9,TMP S LOOP8=0
F S LOOP8=$O(PRCFA("BOC",LOOP8)) Q:LOOP8=""!(LOOP8'>0) D
.S LOOP9=0
.F S LOOP9=$O(PRCFA("BOC",LOOP8,LOOP9)) Q:LOOP9=""!(LOOP9'>0) D
..S TMP=$P(PRCFA("BOC",LOOP8,LOOP9),U,2)
..I TMP="" D
...K PRCFA("BOC",LOOP8,LOOP9)
...K PRCFA("BOCREC",LOOP8)
...K PRCFA("BOCTOT",LOOP8,LOOP9)
...Q
..Q
.Q
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCUFCU1 4147 printed Sep 23, 2025@19:55:50 Page 2
PRCUFCU1 ;WISC/SJG-OBLIGATION CONVERSION UTILITIES CONT ;7/6/94 14:57
+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
DET ; Step 3 - Determine total amts on FMS lines
+1 ; Set in array PRCFA("BOCTOT")
+2 NEW LOOP3,LOOP4
SET LOOP3=0
+3 FOR
SET LOOP3=$ORDER(^PRC(442,LOOP,22,"B",LOOP3))
if LOOP3=""!(LOOP3'>0)
QUIT
Begin DoDot:1
+4 SET LOOP4=0
FOR
SET LOOP4=$ORDER(^PRC(442,LOOP,22,"B",LOOP3,LOOP4))
if LOOP4=""!(LOOP4'>0)
QUIT
Begin DoDot:2
+5 SET NODET=^PRC(442,LOOP,22,LOOP4,0)
+6 SET BOC=$PIECE(NODET,U)
SET AMTTOT=$PIECE(NODET,U,2)
SET FMSLIN=$PIECE(NODET,U,3)
+7 IF FMSLIN=991&(AMTTOT=0)
QUIT
+8 SET PRCFA("BOCTOT",BOC,FMSLIN)=BOC_U_AMTTOT_U_FMSLIN_U_"I"
+9 KILL NODET,BOC,AMTTOT,FMSLIN
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT
RECD ; Step 4 - Calculate receiving line BOCS for FMS lines
+1 ; Set in array PRCFA("BOCREC")
+2 NEW LINE
SET LINE=0
SET PRCFA("LIQ")=0
+3 FOR
SET LINE=$ORDER(^PRC(442,LOOP,2,LINE))
if LINE=""!(LINE'>0)
QUIT
Begin DoDot:1
+4 SET PRCFA("TEMP")=^(LINE,0)
+5 SET BOC=+$PIECE(PRCFA("TEMP"),U,4)
+6 IF '$DATA(PRCFA("BOCREC",BOC))
SET PRCFA("BOCREC",BOC)=BOC
SET $PIECE(PRCFA("BOCREC",BOC),U,2)=0
+7 IF $DATA(^PRC(442,LOOP,2,LINE,3))
Begin DoDot:2
+8 KILL PRCFA("TEMP")
SET PRCFA("RECLINE")=0
+9 SET RECLINE=0
FOR
SET RECLINE=$ORDER(^PRC(442,LOOP,2,LINE,3,RECLINE))
if RECLINE=""!(RECLINE'>0)
QUIT
Begin DoDot:3
+10 SET PRCFA("REC")=^(RECLINE,0)
+11 SET RECAMT=$PIECE(PRCFA("REC"),U,3)
+12 SET PRCFA("RECLINE")=PRCFA("RECLINE")+RECAMT
+13 QUIT
End DoDot:3
+14 SET TOTREC=$PIECE(PRCFA("BOCREC",BOC),U,2)
SET TOTREC=TOTREC+PRCFA("RECLINE")
+15 SET $PIECE(PRCFA("BOCREC",BOC),U,2)=TOTREC
+16 SET PRCFA("LIQ")=PRCFA("LIQ")+PRCFA("RECLINE")
+17 KILL PRCFA("REC"),PRCFA("RECLINE"),RECAMT,BOC,TOTREC
+18 QUIT
End DoDot:2
+19 KILL PRCFA("TEMP")
+20 QUIT
End DoDot:1
+21 DO ESH
DO SETA
DO SETB
+22 KILL RECAMT,RECLINE,LINE,BOC
+23 QUIT
ESH ; Estimated shipping/handling
+1 NEW ESHAMT,ESHBOC,ESHLIN
+2 DO GENDIQ^PRCFFU7(442,LOOP,"13:13.05","IE","")
+3 SET ESHAMT=$GET(PRCTMP(442,LOOP,13,"I"))
+4 IF ESHAMT]""
Begin DoDot:1
+5 NEW AMTREC
+6 SET ESHBOC=+$GET(PRCTMP(442,LOOP,13.05,"I"))
+7 IF $PIECE(PRCFA("MOD"),U)="M"
SET PRCFA("BOCREC",ESHBOC,991)=ESHBOC_U_ESHAMT
+8 IF $PIECE(PRCFA("MOD"),U)="E"
SET PRCFA("BOCREC",ESHBOC,991)=ESHBOC_U_"0"
+9 SET PRCFA("LIQ")=PRCFA("LIQ")+ESHAMT
+10 SET PRCFA("BOCREC","ESH")=ESHBOC_U_ESHAMT_"^991^I"
+11 QUIT
End DoDot:1
QUIT
SETA ;
+1 NEW LOOP5,LINE
SET LOOP5=0
+2 FOR
SET LOOP5=$ORDER(PRCFA("BOCTOT",LOOP5))
if LOOP5=""!(LOOP5'>0)
QUIT
Begin DoDot:1
+3 SET LINE=0
+4 SET LINE=$ORDER(PRCFA("BOCTOT",LOOP5,LINE))
+5 SET PRCFA("BOC",LOOP5,LINE)=LOOP5_U_U_LINE_U_"I"
+6 QUIT
End DoDot:1
+7 QUIT
SETB ;
+1 NEW LOOP5,LINE
SET LOOP5=0
+2 FOR
SET LOOP5=$ORDER(PRCFA("BOCTOT",LOOP5))
if LOOP5=""!(LOOP5'>0)
QUIT
Begin DoDot:1
+3 SET LINE=0
+4 SET LINE=$ORDER(PRCFA("BOCTOT",LOOP5,LINE))
+5 if LINE=991
QUIT
+6 SET PRCFA("BOCREC",LOOP5,LINE)=PRCFA("BOCREC",LOOP5)
+7 QUIT
End DoDot:1
+8 QUIT
CALC ; Step 5 - Calculate amts not yet received to be sent to FMS
+1 ; Set into array PRCFA("BOC")
+2 NEW ESHAMT,ESHBOC,ESHLIN
+3 IF $DATA(PRCFA("BOCREC","ESH"))
Begin DoDot:1
+4 SET ESHBOC=$PIECE(PRCFA("BOCREC","ESH"),U)
SET ESHAMT=$PIECE(PRCFA("BOCREC","ESH"),U,2)
SET ESHLIN=$PIECE(PRCFA("BOCREC","ESH"),U,3)
+5 QUIT
End DoDot:1
+6 NEW LOOP6
SET LOOP6=0
SET PRCFCHG("BOC","TOT")=0
+7 FOR
SET LOOP6=$ORDER(PRCFA("BOCTOT",LOOP6))
if LOOP6=""!(LOOP6'>0)
QUIT
Begin DoDot:1
+8 SET LOOP7=0
+9 FOR
SET LOOP7=$ORDER(PRCFA("BOCTOT",LOOP6,LOOP7))
if LOOP7=""!(LOOP7'>0)
QUIT
Begin DoDot:2
+10 SET TOTAMT=$PIECE(PRCFA("BOCTOT",LOOP6,LOOP7),U,2)
+11 SET RECAMT=$PIECE(PRCFA("BOCREC",LOOP6,LOOP7),U,2)
+12 SET FMSAMT=TOTAMT-RECAMT
+13 IF FMSAMT>0
Begin DoDot:3
+14 IF $DATA(PRCFA("BOCREC","ESH"))
IF (ESHBOC=LOOP6)&(ESHAMT=RECAMT)&(ESHLIN=LOOP7)
QUIT
+15 SET PRCFCHG("BOC",LOOP6,LOOP7)=LOOP6_U_FMSAMT_U_LOOP7_"^I"
+16 SET PRCFCHG("BOC","TOT")=PRCFCHG("BOC","TOT")+FMSAMT
+17 SET $PIECE(PRCFA("BOC",LOOP6,LOOP7),U,2)=FMSAMT
End DoDot:3
+18 QUIT
End DoDot:2
End DoDot:1
+19 SET TOTAMT=PRCFCHG("BOC","TOT")
+20 DO CLEAN
+21 KILL LOOP7,FMSAMT,RECAMT
+22 QUIT
CLEAN ; Clean up arrays
+1 IF $DATA(PRCFA("BOCREC","ESH"))
IF $PIECE(PRCFA("MOD"),U)="M"
Begin DoDot:1
+2 NEW ESHBOC,ESHLIN
+3 SET ESHBOC=$PIECE(PRCFA("BOCREC","ESH"),U)
+4 SET ESHLIN=$PIECE(PRCFA("BOCREC","ESH"),U,3)
+5 KILL PRCFA("BOCTOT",ESHBOC,ESHLIN)
+6 KILL PRCFA("BOC",ESHBOC,ESHLIN)
+7 KILL PRCFA("BOCREC",ESHBOC,ESHLIN)
+8 KILL PRCFA("BOCREC","ESH")
+9 QUIT
End DoDot:1
+10 NEW LOOP8,LOOP9,TMP
SET LOOP8=0
+11 FOR
SET LOOP8=$ORDER(PRCFA("BOC",LOOP8))
if LOOP8=""!(LOOP8'>0)
QUIT
Begin DoDot:1
+12 SET LOOP9=0
+13 FOR
SET LOOP9=$ORDER(PRCFA("BOC",LOOP8,LOOP9))
if LOOP9=""!(LOOP9'>0)
QUIT
Begin DoDot:2
+14 SET TMP=$PIECE(PRCFA("BOC",LOOP8,LOOP9),U,2)
+15 IF TMP=""
Begin DoDot:3
+16 KILL PRCFA("BOC",LOOP8,LOOP9)
+17 KILL PRCFA("BOCREC",LOOP8)
+18 KILL PRCFA("BOCTOT",LOOP8,LOOP9)
+19 QUIT
End DoDot:3
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
+22 QUIT
