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 ---[H[J[2J[HFBAAUVC 2420 printed Nov 22, 2024@17:07:04 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
