source: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAAUTL6.m@ 1000

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

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1FBAAUTL6 ;WCIOFO/SAB-UTILITY ROUTINE ;9/11/97
2 ;;3.5;FEE BASIS;**9,36**;JAN 30, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4VGRP(FBDA) ; Validate/Correct Socioeconomic Groups Extrinsic Function
5 ; called by input templates FBAA NEW VENDOR, FBAA EDIT VENDOR
6 ; input FBDA - ien of vendor in 161.2
7 ; returns - True when groups were changed or False when groups were OK
8 N FB,FBBT,FBCHG,FBFDA,FBG,FBIENS
9 S FBCHG=0
10 ; get current business type and groups
11 S FBBT=$$GET1^DIQ(161.2,FBDA,24,"I")
12 D GETS^DIQ(161.2,FBDA_",","25*","IE","FB")
13 ; check groups against type
14 S FBIENS="" F S FBIENS=$O(FB(161.225,FBIENS)) Q:FBIENS="" D
15 . I FBBT]"",$$GET1^DIQ(420.6,FB(161.225,FBIENS,.01,"I"),5)[FBBT Q ; OK
16 . W !," Group ",FB(161.225,FBIENS,.01,"E")," inappropriate for Business Type. Deleting..."
17 . S FBFDA(161.225,FBIENS,.01)="@"
18 . K FB(161.225,FBIENS)
19 I $D(FBFDA) D FILE^DIE("","FBFDA") D MSG^DIALOG() S FBCHG=1
20 ; check group combinations
21 ; first build list by group codes
22 S FBIENS="" F S FBIENS=$O(FB(161.225,FBIENS)) Q:FBIENS="" D
23 . S FBG(FB(161.225,FBIENS,.01,"E"))=FBIENS
24 . S FBG=$G(FBG)+1
25 ; check use of OO with others
26 I $D(FBG("OO")),$G(FBG)>1 D
27 . W !," Group OO can't be used with other groups. Deleting OO..."
28 . S FBFDA(161.225,FBG("OO"),.01)="@"
29 I $D(FBFDA) D FILE^DIE("","FBFDA") D MSG^DIALOG() S FBCHG=1
30 ; check S
31 I $D(FBG("RV")),'$D(FBG("S")) D
32 . W !," Group S must be specified with group RV. Adding S..."
33 . S FBFDA(161.225,"+1,"_FBDA_",",.01)="S"
34 . D UPDATE^DIE("E","FBFDA") D MSG^DIALOG() S FBCHG=1
35 Q FBCHG
36 ;
37GETGRP(FBDA,FBMAX) ; Get Socioeconomic Groups for a Vendor
38 ; in FBDA - vendor ien
39 ; FBMAX - (optional) maximum number of groups to retrieve
40 ; out FBSG( array - i.e. FBSG(1)=code, FBSG(2)=code, etc.
41 N FB,FBC,FBIENS
42 K FBSG
43 I '$G(FBMAX) S FBMAX=999
44 D GETS^DIQ(161.2,FBDA_",","25*","","FB")
45 S FBC=0,FBIENS=""
46 F S FBIENS=$O(FB(161.225,FBIENS)) Q:FBIENS="" D Q:(FBC=FBMAX)
47 . S FBC=FBC+1,FBSG(FBC)=FB(161.225,FBIENS,.01)
48 Q
49 ;
50GRPDIF(FBDA) ; Socioeconomic Groups Different Extrinsic Function?
51 ; in FBDA - vendor ien
52 ; FBSG( array of groups
53 ; returns True (when different) or False (when equivalent)
54 N FB,FBARRAY,FBFILE,FBG,FBX,FBY
55 ; create sorted list of groups from array
56 S FBX="" F S FBX=$O(FBSG(FBX)) Q:FBX="" D
57 . S FBY=FBSG(FBX) Q:FBY=""
58 . S FBG(FBY)=""
59 S (FBARRAY,FBY)="" F S FBY=$O(FBG(FBY)) Q:FBY="" S FBARRAY=FBARRAY_FBY
60 ; create sorted list of groups from file
61 D GETS^DIQ(161.2,FBDA_",","25*","","FB")
62 K FBG
63 S FBX="" F S FBX=$O(FB(161.225,FBX)) Q:FBX="" D
64 . S FBY=FB(161.225,FBX,.01) Q:FBY=""
65 . S FBG(FBY)=""
66 S (FBFILE,FBY)="" F S FBY=$O(FBG(FBY)) Q:FBY="" S FBFILE=FBFILE_FBY
67 ; compare
68 Q FBFILE'=FBARRAY
69 ;
70UPDGRP(FBDA) ; Update Socioeconomic Groups of Vendor
71 ; in FBDA - vendor ien
72 ; FBSG( array
73 N FB,FBBT,FBFDA,FBI,FBIENS
74 ; delete current vendor groups
75 D GETS^DIQ(161.2,FBDA_",","25*","","FB")
76 S FBIENS="" F S FBIENS=$O(FB(161.225,FBIENS)) Q:FBIENS="" D
77 . S FBFDA(161.225,FBIENS,.01)="@"
78 I $D(FBFDA) D FILE^DIE("","FBFDA")
79 ; store groups from array in vendor
80 N FBVNCOD,FBVNDAT,FBVNDBL
81 S FBBT=$$GET1^DIQ(161.2,FBDA,24,"I") ;get business type
82 S FBI=0 F S FBI=$O(FBSG(FBI)) Q:'FBI D
83 . Q:FBSG(FBI)=""
84 . ; find internal values with correct business type and effective date
85 . S FBVNCOD=0
86 . F S FBVNCOD=$O(^PRCD(420.6,"B",FBSG(FBI),FBVNCOD)) Q:+FBVNCOD=0 S FBVNDAT=$G(^PRCD(420.6,FBVNCOD,0)) Q:$P(FBVNDAT,"^",6)[$G(FBBT)&($P(FBVNDAT,"^",3)=1)
87 . Q:+FBVNCOD=0
88 . ;do not file "Q" for SMALL BUSINESS - file "S" instead
89 . S:FBVNCOD=158 FBVNCOD=162
90 . ;R->RV for SMALL BUSINESS
91 . S:FBVNCOD=159 FBVNCOD=167
92 . ; place internal value in FBFDA if it is not already in there
93 . D Q:FBVNDBL'="" S FBFDA(161.225,"+"_FBI_","_FBDA_",",.01)=FBVNCOD
94 . . S FBVNDBL=0 F S FBVNDBL=$O(FBFDA(161.225,FBVNDBL)) Q:'FBVNDBL Q:FBFDA(161.225,FBVNDBL,".01")=FBVNCOD
95 ; file internal values in file
96 I $D(FBFDA) D UPDATE^DIE("","FBFDA")
97 Q
Note: See TracBrowser for help on using the repository browser.