- 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 Feb 18, 2025@23:46:08 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
