FBAAUVC.m

FBAAUVC ;WOIFO/SAB-UPDATE VENDOR CODES ;11/27/2000

 ;;3.5;FEE BASIS;**24**;JAN 30, 1995

 ;This routine may be tasked (or directly called) from the patch

 ;FB*3.5*24 post install routine.

 Q

 ;

ENQ ; Tasked Entry Point

 N FBERR

 D UPDPART

 D UPDSPEC

 Q

 ;

UPDPART ;Update Selected Participation Code(s)

 ;May also be directly called from FBXIP24

 N FBCODE,FBDA,FBFDA,FBI,FBNAME,FBX,X,Y

 K FBERR

 ;

 ; update Part Codes

 K FBFDA

 ; loop thru Part Codes

 F FBI=1:1 S FBX=$P($T(PART+FBI),";;",2) Q:FBX="END"  D

 . S FBCODE=$P(FBX,U)

 . S FBNAME=$P(FBX,U,2)

 . Q:FBCODE=""

 . ;

 . ; locate Part Code in file

 . S FBDA=$$FIND1^DIC(161.81,"","X",FBCODE,"C")

 . ;

 . ; if PART CODE found then check and if necessary add to update array

 . I FBDA D

 . . I $$GET1^DIQ(161.81,FBDA_",",.01)=FBNAME Q

 . . S FBFDA(161.81,FBDA_",",.01)=FBNAME

 . ;

 . ; if Part Code not found then add it

 . I 'FBDA D

 . . N DA,DD,DIC,DINUM,DLAYGO,DO,X

 . . S DIC="^FBAA(161.81,",DIC(0)="L",DLAYGO=161.81

 . . S X=FBNAME Q:X=""

 . . S DIC("DR")="1////^S X=FBCODE"

 . . I +FBCODE,'$D(^FBAA(161.81,+FBCODE,0)) S DINUM=+FBCODE

 . . D FILE^DICN

 . . I Y<0 S FBERR(FBCODE)=""

 ;

 ; actually update the found Part Codes

 I $D(FBFDA) D FILE^DIE("","FBFDA")

 ;

 Q

 ;

PART ;austin code^name for Participation Code(s)

 ;;15^DOCTOR OF CHIROPRACTIC

 ;;END

 ;

UPDSPEC ;Update Selected Specialty Code(s)

 ;May also be directly called from FBXIP24

 N FBCODE,FBDA,FBFDA,FBI,FBNAME,FBX,X,Y

 K FBERR

 ;

 ; update Specialty Code(s)

 K FBFDA

 ; loop thru Specialties

 F FBI=1:1 S FBX=$P($T(SPEC+FBI),";;",2) Q:FBX="END"  D

 . S FBCODE=$P(FBX,U)

 . S FBNAME=$P(FBX,U,2)

 . Q:FBCODE=""

 . ;

 . ; locate Specialty Code in file

 . S FBDA=$$FIND1^DIC(161.6,"","X",FBCODE,"C")

 . ;

 . ; if Spec Code found then check and if necessary add to update array

 . I FBDA D

 . . I $$GET1^DIQ(161.6,FBDA_",",.01)=FBNAME Q

 . . S FBFDA(161.6,FBDA_",",.01)=FBNAME

 . ;

 . ; if Specialty Code not found then add it

 . I 'FBDA D

 . . N DA,DD,DIC,DINUM,DLAYGO,DO,X

 . . S DIC="^FBAA(161.6,",DIC(0)="L",DLAYGO=161.6

 . . S X=FBNAME Q:X=""

 . . S DIC("DR")="1////^S X=FBCODE"

 . . D FILE^DICN

 . . I Y<0 S FBERR(FBCODE)=""

 ;

 ; actually update the found Specialty Codes

 I $D(FBFDA) D FILE^DIE("","FBFDA")

 ;

 Q

 ;

SPEC ;;austin code^name for Specialty Code(s)

 ;;53^CHIROPRACTIC

 ;;END

 ;

 ;FBAAUVC

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---FBAAUVC   2420     printed  Mar 13, 2025@21:01:35                                                                                                                                                                                                     Page 2

FBAAUVC   ;WOIFO/SAB-UPDATE VENDOR CODES ;11/27/2000

 +1       ;;3.5;FEE BASIS;**24**;JAN 30, 1995

 +2       ;This routine may be tasked (or directly called) from the patch

 +3       ;FB*3.5*24 post install routine.

 +4        QUIT 

 +5       ;

ENQ       ; Tasked Entry Point

 +1        NEW FBERR

 +2        DO UPDPART

 +3        DO UPDSPEC

 +4        QUIT 

 +5       ;

UPDPART   ;Update Selected Participation Code(s)

 +1       ;May also be directly called from FBXIP24

 +2        NEW FBCODE,FBDA,FBFDA,FBI,FBNAME,FBX,X,Y

 +3        KILL FBERR

 +4       ;

 +5       ; update Part Codes

 +6        KILL FBFDA

 +7       ; loop thru Part Codes

 +8        FOR FBI=1:1

               SET FBX=$PIECE($TEXT(PART+FBI),";;",2)

               if FBX="END"

                   QUIT 

               Begin DoDot:1

 +9                SET FBCODE=$PIECE(FBX,U)

 +10               SET FBNAME=$PIECE(FBX,U,2)

 +11               if FBCODE=""

                       QUIT 

 +12      ;

 +13      ; locate Part Code in file

 +14               SET FBDA=$$FIND1^DIC(161.81,"","X",FBCODE,"C")

 +15      ;

 +16      ; if PART CODE found then check and if necessary add to update array

 +17               IF FBDA

                       Begin DoDot:2

 +18                       IF $$GET1^DIQ(161.81,FBDA_",",.01)=FBNAME

                               QUIT 

 +19                       SET FBFDA(161.81,FBDA_",",.01)=FBNAME

                       End DoDot:2

 +20      ;

 +21      ; if Part Code not found then add it

 +22               IF 'FBDA

                       Begin DoDot:2

 +23                       NEW DA,DD,DIC,DINUM,DLAYGO,DO,X

 +24                       SET DIC="^FBAA(161.81,"

                           SET DIC(0)="L"

                           SET DLAYGO=161.81

 +25                       SET X=FBNAME

                           if X=""

                               QUIT 

 +26                       SET DIC("DR")="1////^S X=FBCODE"

 +27                       IF +FBCODE

                               IF '$DATA(^FBAA(161.81,+FBCODE,0))

                                   SET DINUM=+FBCODE

 +28                       DO FILE^DICN

 +29                       IF Y<0

                               SET FBERR(FBCODE)=""

                       End DoDot:2

               End DoDot:1

 +30      ;

 +31      ; actually update the found Part Codes

 +32       IF $DATA(FBFDA)

               DO FILE^DIE("","FBFDA")

 +33      ;

 +34       QUIT 

 +35      ;

PART      ;austin code^name for Participation Code(s)

 +1       ;;15^DOCTOR OF CHIROPRACTIC

 +2       ;;END

 +3       ;

UPDSPEC   ;Update Selected Specialty Code(s)

 +1       ;May also be directly called from FBXIP24

 +2        NEW FBCODE,FBDA,FBFDA,FBI,FBNAME,FBX,X,Y

 +3        KILL FBERR

 +4       ;

 +5       ; update Specialty Code(s)

 +6        KILL FBFDA

 +7       ; loop thru Specialties

 +8        FOR FBI=1:1

               SET FBX=$PIECE($TEXT(SPEC+FBI),";;",2)

               if FBX="END"

                   QUIT 

               Begin DoDot:1

 +9                SET FBCODE=$PIECE(FBX,U)

 +10               SET FBNAME=$PIECE(FBX,U,2)

 +11               if FBCODE=""

                       QUIT 

 +12      ;

 +13      ; locate Specialty Code in file

 +14               SET FBDA=$$FIND1^DIC(161.6,"","X",FBCODE,"C")

 +15      ;

 +16      ; if Spec Code found then check and if necessary add to update array

 +17               IF FBDA

                       Begin DoDot:2

 +18                       IF $$GET1^DIQ(161.6,FBDA_",",.01)=FBNAME

                               QUIT 

 +19                       SET FBFDA(161.6,FBDA_",",.01)=FBNAME

                       End DoDot:2

 +20      ;

 +21      ; if Specialty Code not found then add it

 +22               IF 'FBDA

                       Begin DoDot:2

 +23                       NEW DA,DD,DIC,DINUM,DLAYGO,DO,X

 +24                       SET DIC="^FBAA(161.6,"

                           SET DIC(0)="L"

                           SET DLAYGO=161.6

 +25                       SET X=FBNAME

                           if X=""

                               QUIT 

 +26                       SET DIC("DR")="1////^S X=FBCODE"

 +27                       DO FILE^DICN

 +28                       IF Y<0

                               SET FBERR(FBCODE)=""

                       End DoDot:2

               End DoDot:1

 +29      ;

 +30      ; actually update the found Specialty Codes

 +31       IF $DATA(FBFDA)

               DO FILE^DIE("","FBFDA")

 +32      ;

 +33       QUIT 

 +34      ;

SPEC      ;;austin code^name for Specialty Code(s)

 +1       ;;53^CHIROPRACTIC

 +2       ;;END

 +3       ;

 +4       ;FBAAUVC