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 Dec 13, 2024@01:56:51 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
