source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCUFCU1.m@ 1800

Last change on this file since 1800 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.9 KB
RevLine 
[613]1PRCUFCU1 ;WISC/SJG-OBLIGATION CONVERSION UTILITIES CONT ;7/6/94 14:57
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 QUIT
6 ; No top level entry
7DET ; Step 3 - Determine total amts on FMS lines
8 ; Set in array PRCFA("BOCTOT")
9 N LOOP3,LOOP4 S LOOP3=0
10 F S LOOP3=$O(^PRC(442,LOOP,22,"B",LOOP3)) Q:LOOP3=""!(LOOP3'>0) D
11 .S LOOP4=0 F S LOOP4=$O(^PRC(442,LOOP,22,"B",LOOP3,LOOP4)) Q:LOOP4=""!(LOOP4'>0) D
12 ..S NODET=^PRC(442,LOOP,22,LOOP4,0)
13 ..S BOC=$P(NODET,U),AMTTOT=$P(NODET,U,2),FMSLIN=$P(NODET,U,3)
14 ..I FMSLIN=991&(AMTTOT=0) Q
15 ..S PRCFA("BOCTOT",BOC,FMSLIN)=BOC_U_AMTTOT_U_FMSLIN_U_"I"
16 ..K NODET,BOC,AMTTOT,FMSLIN
17 ..Q
18 .Q
19 QUIT
20RECD ; Step 4 - Calculate receiving line BOCS for FMS lines
21 ; Set in array PRCFA("BOCREC")
22 N LINE S LINE=0,PRCFA("LIQ")=0
23 F S LINE=$O(^PRC(442,LOOP,2,LINE)) Q:LINE=""!(LINE'>0) D
24 .S PRCFA("TEMP")=^(LINE,0)
25 .S BOC=+$P(PRCFA("TEMP"),U,4)
26 .I '$D(PRCFA("BOCREC",BOC)) S PRCFA("BOCREC",BOC)=BOC,$P(PRCFA("BOCREC",BOC),U,2)=0
27 .I $D(^PRC(442,LOOP,2,LINE,3)) D
28 ..K PRCFA("TEMP") S PRCFA("RECLINE")=0
29 ..S RECLINE=0 F S RECLINE=$O(^PRC(442,LOOP,2,LINE,3,RECLINE)) Q:RECLINE=""!(RECLINE'>0) D
30 ...S PRCFA("REC")=^(RECLINE,0)
31 ...S RECAMT=$P(PRCFA("REC"),U,3)
32 ...S PRCFA("RECLINE")=PRCFA("RECLINE")+RECAMT
33 ...Q
34 ..S TOTREC=$P(PRCFA("BOCREC",BOC),U,2),TOTREC=TOTREC+PRCFA("RECLINE")
35 ..S $P(PRCFA("BOCREC",BOC),U,2)=TOTREC
36 ..S PRCFA("LIQ")=PRCFA("LIQ")+PRCFA("RECLINE")
37 ..K PRCFA("REC"),PRCFA("RECLINE"),RECAMT,BOC,TOTREC
38 ..Q
39 .K PRCFA("TEMP")
40 .Q
41 D ESH,SETA,SETB
42 KILL RECAMT,RECLINE,LINE,BOC
43 QUIT
44ESH ; Estimated shipping/handling
45 N ESHAMT,ESHBOC,ESHLIN
46 D GENDIQ^PRCFFU7(442,LOOP,"13:13.05","IE","")
47 S ESHAMT=$G(PRCTMP(442,LOOP,13,"I"))
48 I ESHAMT]"" D Q
49 .N AMTREC
50 .S ESHBOC=+$G(PRCTMP(442,LOOP,13.05,"I"))
51 .I $P(PRCFA("MOD"),U)="M" S PRCFA("BOCREC",ESHBOC,991)=ESHBOC_U_ESHAMT
52 .I $P(PRCFA("MOD"),U)="E" S PRCFA("BOCREC",ESHBOC,991)=ESHBOC_U_"0"
53 .S PRCFA("LIQ")=PRCFA("LIQ")+ESHAMT
54 .S PRCFA("BOCREC","ESH")=ESHBOC_U_ESHAMT_"^991^I"
55 .Q
56SETA ;
57 N LOOP5,LINE S LOOP5=0
58 F S LOOP5=$O(PRCFA("BOCTOT",LOOP5)) Q:LOOP5=""!(LOOP5'>0) D
59 .S LINE=0
60 .S LINE=$O(PRCFA("BOCTOT",LOOP5,LINE))
61 .S PRCFA("BOC",LOOP5,LINE)=LOOP5_U_U_LINE_U_"I"
62 .Q
63 QUIT
64SETB ;
65 N LOOP5,LINE S LOOP5=0
66 F S LOOP5=$O(PRCFA("BOCTOT",LOOP5)) Q:LOOP5=""!(LOOP5'>0) D
67 .S LINE=0
68 .S LINE=$O(PRCFA("BOCTOT",LOOP5,LINE))
69 .Q:LINE=991
70 .S PRCFA("BOCREC",LOOP5,LINE)=PRCFA("BOCREC",LOOP5)
71 .Q
72 QUIT
73CALC ; Step 5 - Calculate amts not yet received to be sent to FMS
74 ; Set into array PRCFA("BOC")
75 N ESHAMT,ESHBOC,ESHLIN
76 I $D(PRCFA("BOCREC","ESH")) D
77 .S ESHBOC=$P(PRCFA("BOCREC","ESH"),U),ESHAMT=$P(PRCFA("BOCREC","ESH"),U,2),ESHLIN=$P(PRCFA("BOCREC","ESH"),U,3)
78 .Q
79 N LOOP6 S LOOP6=0,PRCFCHG("BOC","TOT")=0
80 F S LOOP6=$O(PRCFA("BOCTOT",LOOP6)) Q:LOOP6=""!(LOOP6'>0) D
81 .S LOOP7=0
82 .F S LOOP7=$O(PRCFA("BOCTOT",LOOP6,LOOP7)) Q:LOOP7=""!(LOOP7'>0) D
83 ..S TOTAMT=$P(PRCFA("BOCTOT",LOOP6,LOOP7),U,2)
84 ..S RECAMT=$P(PRCFA("BOCREC",LOOP6,LOOP7),U,2)
85 ..S FMSAMT=TOTAMT-RECAMT
86 ..I FMSAMT>0 D
87 ...I $D(PRCFA("BOCREC","ESH")) I (ESHBOC=LOOP6)&(ESHAMT=RECAMT)&(ESHLIN=LOOP7) Q
88 ...S PRCFCHG("BOC",LOOP6,LOOP7)=LOOP6_U_FMSAMT_U_LOOP7_"^I"
89 ...S PRCFCHG("BOC","TOT")=PRCFCHG("BOC","TOT")+FMSAMT
90 ...S $P(PRCFA("BOC",LOOP6,LOOP7),U,2)=FMSAMT
91 ..Q
92 S TOTAMT=PRCFCHG("BOC","TOT")
93 D CLEAN
94 KILL LOOP7,FMSAMT,RECAMT
95 QUIT
96CLEAN ; Clean up arrays
97 I $D(PRCFA("BOCREC","ESH")),$P(PRCFA("MOD"),U)="M" D
98 .N ESHBOC,ESHLIN
99 .S ESHBOC=$P(PRCFA("BOCREC","ESH"),U)
100 .S ESHLIN=$P(PRCFA("BOCREC","ESH"),U,3)
101 .K PRCFA("BOCTOT",ESHBOC,ESHLIN)
102 .K PRCFA("BOC",ESHBOC,ESHLIN)
103 .K PRCFA("BOCREC",ESHBOC,ESHLIN)
104 .K PRCFA("BOCREC","ESH")
105 .Q
106 N LOOP8,LOOP9,TMP S LOOP8=0
107 F S LOOP8=$O(PRCFA("BOC",LOOP8)) Q:LOOP8=""!(LOOP8'>0) D
108 .S LOOP9=0
109 .F S LOOP9=$O(PRCFA("BOC",LOOP8,LOOP9)) Q:LOOP9=""!(LOOP9'>0) D
110 ..S TMP=$P(PRCFA("BOC",LOOP8,LOOP9),U,2)
111 ..I TMP="" D
112 ...K PRCFA("BOC",LOOP8,LOOP9)
113 ...K PRCFA("BOCREC",LOOP8)
114 ...K PRCFA("BOCTOT",LOOP8,LOOP9)
115 ...Q
116 ..Q
117 .Q
118 QUIT
Note: See TracBrowser for help on using the repository browser.