- FBAAUTL6 ;WCIOFO/SAB-UTILITY ROUTINE ;9/11/97
- ;;3.5;FEE BASIS;**9,36**;JAN 30, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- VGRP(FBDA) ; Validate/Correct Socioeconomic Groups Extrinsic Function
- ; called by input templates FBAA NEW VENDOR, FBAA EDIT VENDOR
- ; input FBDA - ien of vendor in 161.2
- ; returns - True when groups were changed or False when groups were OK
- N FB,FBBT,FBCHG,FBFDA,FBG,FBIENS
- S FBCHG=0
- ; get current business type and groups
- S FBBT=$$GET1^DIQ(161.2,FBDA,24,"I")
- D GETS^DIQ(161.2,FBDA_",","25*","IE","FB")
- ; check groups against type
- S FBIENS="" F S FBIENS=$O(FB(161.225,FBIENS)) Q:FBIENS="" D
- . I FBBT]"",$$GET1^DIQ(420.6,FB(161.225,FBIENS,.01,"I"),5)[FBBT Q ; OK
- . W !," Group ",FB(161.225,FBIENS,.01,"E")," inappropriate for Business Type. Deleting..."
- . S FBFDA(161.225,FBIENS,.01)="@"
- . K FB(161.225,FBIENS)
- I $D(FBFDA) D FILE^DIE("","FBFDA") D MSG^DIALOG() S FBCHG=1
- ; check group combinations
- ; first build list by group codes
- S FBIENS="" F S FBIENS=$O(FB(161.225,FBIENS)) Q:FBIENS="" D
- . S FBG(FB(161.225,FBIENS,.01,"E"))=FBIENS
- . S FBG=$G(FBG)+1
- ; check use of OO with others
- I $D(FBG("OO")),$G(FBG)>1 D
- . W !," Group OO can't be used with other groups. Deleting OO..."
- . S FBFDA(161.225,FBG("OO"),.01)="@"
- I $D(FBFDA) D FILE^DIE("","FBFDA") D MSG^DIALOG() S FBCHG=1
- ; check S
- I $D(FBG("RV")),'$D(FBG("S")) D
- . W !," Group S must be specified with group RV. Adding S..."
- . S FBFDA(161.225,"+1,"_FBDA_",",.01)="S"
- . D UPDATE^DIE("E","FBFDA") D MSG^DIALOG() S FBCHG=1
- Q FBCHG
- ;
- GETGRP(FBDA,FBMAX) ; Get Socioeconomic Groups for a Vendor
- ; in FBDA - vendor ien
- ; FBMAX - (optional) maximum number of groups to retrieve
- ; out FBSG( array - i.e. FBSG(1)=code, FBSG(2)=code, etc.
- N FB,FBC,FBIENS
- K FBSG
- I '$G(FBMAX) S FBMAX=999
- D GETS^DIQ(161.2,FBDA_",","25*","","FB")
- S FBC=0,FBIENS=""
- F S FBIENS=$O(FB(161.225,FBIENS)) Q:FBIENS="" D Q:(FBC=FBMAX)
- . S FBC=FBC+1,FBSG(FBC)=FB(161.225,FBIENS,.01)
- Q
- ;
- GRPDIF(FBDA) ; Socioeconomic Groups Different Extrinsic Function?
- ; in FBDA - vendor ien
- ; FBSG( array of groups
- ; returns True (when different) or False (when equivalent)
- N FB,FBARRAY,FBFILE,FBG,FBX,FBY
- ; create sorted list of groups from array
- S FBX="" F S FBX=$O(FBSG(FBX)) Q:FBX="" D
- . S FBY=FBSG(FBX) Q:FBY=""
- . S FBG(FBY)=""
- S (FBARRAY,FBY)="" F S FBY=$O(FBG(FBY)) Q:FBY="" S FBARRAY=FBARRAY_FBY
- ; create sorted list of groups from file
- D GETS^DIQ(161.2,FBDA_",","25*","","FB")
- K FBG
- S FBX="" F S FBX=$O(FB(161.225,FBX)) Q:FBX="" D
- . S FBY=FB(161.225,FBX,.01) Q:FBY=""
- . S FBG(FBY)=""
- S (FBFILE,FBY)="" F S FBY=$O(FBG(FBY)) Q:FBY="" S FBFILE=FBFILE_FBY
- ; compare
- Q FBFILE'=FBARRAY
- ;
- UPDGRP(FBDA) ; Update Socioeconomic Groups of Vendor
- ; in FBDA - vendor ien
- ; FBSG( array
- N FB,FBBT,FBFDA,FBI,FBIENS
- ; delete current vendor groups
- D GETS^DIQ(161.2,FBDA_",","25*","","FB")
- S FBIENS="" F S FBIENS=$O(FB(161.225,FBIENS)) Q:FBIENS="" D
- . S FBFDA(161.225,FBIENS,.01)="@"
- I $D(FBFDA) D FILE^DIE("","FBFDA")
- ; store groups from array in vendor
- N FBVNCOD,FBVNDAT,FBVNDBL
- S FBBT=$$GET1^DIQ(161.2,FBDA,24,"I") ;get business type
- S FBI=0 F S FBI=$O(FBSG(FBI)) Q:'FBI D
- . Q:FBSG(FBI)=""
- . ; find internal values with correct business type and effective date
- . S FBVNCOD=0
- . 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)
- . Q:+FBVNCOD=0
- . ;do not file "Q" for SMALL BUSINESS - file "S" instead
- . S:FBVNCOD=158 FBVNCOD=162
- . ;R->RV for SMALL BUSINESS
- . S:FBVNCOD=159 FBVNCOD=167
- . ; place internal value in FBFDA if it is not already in there
- . D Q:FBVNDBL'="" S FBFDA(161.225,"+"_FBI_","_FBDA_",",.01)=FBVNCOD
- . . S FBVNDBL=0 F S FBVNDBL=$O(FBFDA(161.225,FBVNDBL)) Q:'FBVNDBL Q:FBFDA(161.225,FBVNDBL,".01")=FBVNCOD
- ; file internal values in file
- I $D(FBFDA) D UPDATE^DIE("","FBFDA")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAUTL6 4070 printed Jan 18, 2025@02:58:04 Page 2
- FBAAUTL6 ;WCIOFO/SAB-UTILITY ROUTINE ;9/11/97
- +1 ;;3.5;FEE BASIS;**9,36**;JAN 30, 1995
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- VGRP(FBDA) ; Validate/Correct Socioeconomic Groups Extrinsic Function
- +1 ; called by input templates FBAA NEW VENDOR, FBAA EDIT VENDOR
- +2 ; input FBDA - ien of vendor in 161.2
- +3 ; returns - True when groups were changed or False when groups were OK
- +4 NEW FB,FBBT,FBCHG,FBFDA,FBG,FBIENS
- +5 SET FBCHG=0
- +6 ; get current business type and groups
- +7 SET FBBT=$$GET1^DIQ(161.2,FBDA,24,"I")
- +8 DO GETS^DIQ(161.2,FBDA_",","25*","IE","FB")
- +9 ; check groups against type
- +10 SET FBIENS=""
- FOR
- SET FBIENS=$ORDER(FB(161.225,FBIENS))
- if FBIENS=""
- QUIT
- Begin DoDot:1
- +11 ; OK
- IF FBBT]""
- IF $$GET1^DIQ(420.6,FB(161.225,FBIENS,.01,"I"),5)[FBBT
- QUIT
- +12 WRITE !," Group ",FB(161.225,FBIENS,.01,"E")," inappropriate for Business Type. Deleting..."
- +13 SET FBFDA(161.225,FBIENS,.01)="@"
- +14 KILL FB(161.225,FBIENS)
- End DoDot:1
- +15 IF $DATA(FBFDA)
- DO FILE^DIE("","FBFDA")
- DO MSG^DIALOG()
- SET FBCHG=1
- +16 ; check group combinations
- +17 ; first build list by group codes
- +18 SET FBIENS=""
- FOR
- SET FBIENS=$ORDER(FB(161.225,FBIENS))
- if FBIENS=""
- QUIT
- Begin DoDot:1
- +19 SET FBG(FB(161.225,FBIENS,.01,"E"))=FBIENS
- +20 SET FBG=$GET(FBG)+1
- End DoDot:1
- +21 ; check use of OO with others
- +22 IF $DATA(FBG("OO"))
- IF $GET(FBG)>1
- Begin DoDot:1
- +23 WRITE !," Group OO can't be used with other groups. Deleting OO..."
- +24 SET FBFDA(161.225,FBG("OO"),.01)="@"
- End DoDot:1
- +25 IF $DATA(FBFDA)
- DO FILE^DIE("","FBFDA")
- DO MSG^DIALOG()
- SET FBCHG=1
- +26 ; check S
- +27 IF $DATA(FBG("RV"))
- IF '$DATA(FBG("S"))
- Begin DoDot:1
- +28 WRITE !," Group S must be specified with group RV. Adding S..."
- +29 SET FBFDA(161.225,"+1,"_FBDA_",",.01)="S"
- +30 DO UPDATE^DIE("E","FBFDA")
- DO MSG^DIALOG()
- SET FBCHG=1
- End DoDot:1
- +31 QUIT FBCHG
- +32 ;
- GETGRP(FBDA,FBMAX) ; Get Socioeconomic Groups for a Vendor
- +1 ; in FBDA - vendor ien
- +2 ; FBMAX - (optional) maximum number of groups to retrieve
- +3 ; out FBSG( array - i.e. FBSG(1)=code, FBSG(2)=code, etc.
- +4 NEW FB,FBC,FBIENS
- +5 KILL FBSG
- +6 IF '$GET(FBMAX)
- SET FBMAX=999
- +7 DO GETS^DIQ(161.2,FBDA_",","25*","","FB")
- +8 SET FBC=0
- SET FBIENS=""
- +9 FOR
- SET FBIENS=$ORDER(FB(161.225,FBIENS))
- if FBIENS=""
- QUIT
- Begin DoDot:1
- +10 SET FBC=FBC+1
- SET FBSG(FBC)=FB(161.225,FBIENS,.01)
- End DoDot:1
- if (FBC=FBMAX)
- QUIT
- +11 QUIT
- +12 ;
- GRPDIF(FBDA) ; Socioeconomic Groups Different Extrinsic Function?
- +1 ; in FBDA - vendor ien
- +2 ; FBSG( array of groups
- +3 ; returns True (when different) or False (when equivalent)
- +4 NEW FB,FBARRAY,FBFILE,FBG,FBX,FBY
- +5 ; create sorted list of groups from array
- +6 SET FBX=""
- FOR
- SET FBX=$ORDER(FBSG(FBX))
- if FBX=""
- QUIT
- Begin DoDot:1
- +7 SET FBY=FBSG(FBX)
- if FBY=""
- QUIT
- +8 SET FBG(FBY)=""
- End DoDot:1
- +9 SET (FBARRAY,FBY)=""
- FOR
- SET FBY=$ORDER(FBG(FBY))
- if FBY=""
- QUIT
- SET FBARRAY=FBARRAY_FBY
- +10 ; create sorted list of groups from file
- +11 DO GETS^DIQ(161.2,FBDA_",","25*","","FB")
- +12 KILL FBG
- +13 SET FBX=""
- FOR
- SET FBX=$ORDER(FB(161.225,FBX))
- if FBX=""
- QUIT
- Begin DoDot:1
- +14 SET FBY=FB(161.225,FBX,.01)
- if FBY=""
- QUIT
- +15 SET FBG(FBY)=""
- End DoDot:1
- +16 SET (FBFILE,FBY)=""
- FOR
- SET FBY=$ORDER(FBG(FBY))
- if FBY=""
- QUIT
- SET FBFILE=FBFILE_FBY
- +17 ; compare
- +18 QUIT FBFILE'=FBARRAY
- +19 ;
- UPDGRP(FBDA) ; Update Socioeconomic Groups of Vendor
- +1 ; in FBDA - vendor ien
- +2 ; FBSG( array
- +3 NEW FB,FBBT,FBFDA,FBI,FBIENS
- +4 ; delete current vendor groups
- +5 DO GETS^DIQ(161.2,FBDA_",","25*","","FB")
- +6 SET FBIENS=""
- FOR
- SET FBIENS=$ORDER(FB(161.225,FBIENS))
- if FBIENS=""
- QUIT
- Begin DoDot:1
- +7 SET FBFDA(161.225,FBIENS,.01)="@"
- End DoDot:1
- +8 IF $DATA(FBFDA)
- DO FILE^DIE("","FBFDA")
- +9 ; store groups from array in vendor
- +10 NEW FBVNCOD,FBVNDAT,FBVNDBL
- +11 ;get business type
- SET FBBT=$$GET1^DIQ(161.2,FBDA,24,"I")
- +12 SET FBI=0
- FOR
- SET FBI=$ORDER(FBSG(FBI))
- if 'FBI
- QUIT
- Begin DoDot:1
- +13 if FBSG(FBI)=""
- QUIT
- +14 ; find internal values with correct business type and effective date
- +15 SET FBVNCOD=0
- +16 FOR
- SET FBVNCOD=$ORDER(^PRCD(420.6,"B",FBSG(FBI),FBVNCOD))
- if +FBVNCOD=0
- QUIT
- SET FBVNDAT=$GET(^PRCD(420.6,FBVNCOD,0))
- if $PIECE(FBVNDAT,"^",6)[$GET(FBBT)&($PIECE(FBVNDAT,"^",3)=1)
- QUIT
- +17 if +FBVNCOD=0
- QUIT
- +18 ;do not file "Q" for SMALL BUSINESS - file "S" instead
- +19 if FBVNCOD=158
- SET FBVNCOD=162
- +20 ;R->RV for SMALL BUSINESS
- +21 if FBVNCOD=159
- SET FBVNCOD=167
- +22 ; place internal value in FBFDA if it is not already in there
- +23 Begin DoDot:2
- +24 SET FBVNDBL=0
- FOR
- SET FBVNDBL=$ORDER(FBFDA(161.225,FBVNDBL))
- if 'FBVNDBL
- QUIT
- if FBFDA(161.225,FBVNDBL,".01")=FBVNCOD
- QUIT
- End DoDot:2
- if FBVNDBL'=""
- QUIT
- SET FBFDA(161.225,"+"_FBI_","_FBDA_",",.01)=FBVNCOD
- End DoDot:1
- +25 ; file internal values in file
- +26 IF $DATA(FBFDA)
- DO UPDATE^DIE("","FBFDA")
- +27 QUIT