source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCUFCU1.m@ 1251

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