FBXIP24 ;WOIFO/SAB-PATCH INSTALL ROUTINE ;12/12/2000
;;3.5;FEE BASIS;**24**;JAN 30, 1995
Q
;
PS ; post-install entry point
; create KIDS checkpoints with call backs
N FBX,Y
F FBX="UPDPOV","VENDOR" D
. S Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP24")
. I 'Y D BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")
Q
;
UPDPOV ; Update Selected Purpose of Visits (POV)
N FBCODE,FBDA,FBFDA,FBI,FBNAME,FBPROG,FBX,X,Y
D BMES^XPDUTL(" Updating selected POVs in the FEE BASIS PURPOSE OF VISIT (161.82) file...")
;
; verify IEN of OUTPATIENT program in FEE BASIS PROGRAM file
I $P($G(^FBAA(161.8,2,0)),U)'="OUTPATIENT" D Q
. D MES^XPDUTL(" ERROR: Fee Program with IEN 2 is not OUTPATIENT.")
. D MES^XPDUTL(" Purpose of Visits could not be updated.")
;
; update POVs
K FBFDA
; loop thru POVs
F FBI=1:1 S FBX=$P($T(POV+FBI),";;",2) Q:FBX="END" D
. S FBCODE=$P(FBX,U)
. S FBNAME=$P(FBX,U,2)
. S FBPROG=$P(FBX,U,3)
. ;
. ; locate POV in file
. S FBDA=$$FIND1^DIC(161.82,"","X",FBCODE,"AC")
. ;
. ; if POV found then check and if necessary add to update array
. I FBDA D
. . I $$GET1^DIQ(161.82,FBDA_",",.01)'=FBNAME S FBFDA(161.82,FBDA_",",.01)=FBNAME
. . I $$GET1^DIQ(161.82,FBDA_",",2,"I")'=FBPROG S FBFDA(161.82,FBDA_",",2)=FBPROG
. ;
. ; if POV not found then add it
. I 'FBDA D
. . N DA,DD,DIC,DINUM,DLAYGO,DO,X
. . S DIC="^FBAA(161.82,",DIC(0)="L",DLAYGO=161.82
. . S X=FBNAME Q:X=""
. . S DIC("DR")="2////^S X=FBPROG;3////^S X=FBCODE"
. . I +FBCODE,'$D(^FBAA(161.82,+FBCODE,0)) S DINUM=+FBCODE
. . D FILE^DICN
. . I Y<0 D MES^XPDUTL("ERROR ADDING POV WITH CODE "_FBCODE)
;
; actually update the found POVs
I $D(FBFDA) D FILE^DIE("","FBFDA")
;
D MES^XPDUTL(" Done.")
Q
;
POV ;austin code^name^fee program for Purpose of Visit (POV) code(s)
;;75^CHIROPRACTIC CARE^2
;;END
;
VENDOR ;Update Vendor Codes
N FBDT,FBNOW
S FBDT="3010103.22" ; effective date/time for PART and SPEC updates
S FBNOW=$$NOW^XLFDT() ; current date/time
;
I FBDT>FBNOW D
. ; Queue task for FBDT since effective date/time is future
. N ZTSK
. S ZTRTN="ENQ^FBAAUVC"
. S ZTDESC="FEE BASIS UPDATE OF PART. AND SPEC. VENDOR CODES"
. S ZTDTH=FBDT
. S ZTIO=""
. D ^%ZTLOAD
. ;
. I '$G(ZTSK) D
. . D BMES^XPDUTL("ERROR. The task was not successfully queued.")
. . D MES^XPDUTL("Please contact National VISTA Support for assistance.")
. ;
. I $G(ZTSK) D
. . D BMES^XPDUTL(" The task to update the PARTICIPATION CODE and the")
. . D MES^XPDUTL(" SPECIALTY CODE was successfully queued.")
. . D MES^XPDUTL(" The task number is "_ZTSK)
. . D MES^XPDUTL(" It will start on "_$$HTE^XLFDT(ZTSK("D")))
;
I FBDT'>FBNOW D
. ; perform update now since effective date has already past
. N FBERR
. ;
. D BMES^XPDUTL(" Updating selected codes in the FEE BASIS PARTICIPATION CODE (161.81) file...")
. D UPDPART^FBAAUVC
. I $D(FBERR) D
. . N FBCODE
. . S FBCODE="" F S FBCODE=$O(FBERR(FBCODE)) Q:FBCODE="" D
. . . D MES^XPDUTL("ERROR ADDING PART CODE "_FBCODE)
. D MES^XPDUTL(" Done.")
. ;
. D BMES^XPDUTL(" Updating selected Codes in the FEE BASIS SPECIALTY CODE (161.6) file...")
. D UPDSPEC^FBAAUVC
. I $D(FBERR) D
. . N FBCODE
. . S FBCODE="" F S FBCODE=$O(FBERR(FBCODE)) Q:FBCODE="" D
. . . D MES^XPDUTL("ERROR ADDING SPECIALTY CODE "_FBCODE)
. D MES^XPDUTL(" Done.")
;
;FBXIP24
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBXIP24 3437 printed Aug 26, 2025@22:17:24 Page 2
FBXIP24 ;WOIFO/SAB-PATCH INSTALL ROUTINE ;12/12/2000
+1 ;;3.5;FEE BASIS;**24**;JAN 30, 1995
+2 QUIT
+3 ;
PS ; post-install entry point
+1 ; create KIDS checkpoints with call backs
+2 NEW FBX,Y
+3 FOR FBX="UPDPOV","VENDOR"
Begin DoDot:1
+4 SET Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP24")
+5 IF 'Y
DO BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")
End DoDot:1
+6 QUIT
+7 ;
UPDPOV ; Update Selected Purpose of Visits (POV)
+1 NEW FBCODE,FBDA,FBFDA,FBI,FBNAME,FBPROG,FBX,X,Y
+2 DO BMES^XPDUTL(" Updating selected POVs in the FEE BASIS PURPOSE OF VISIT (161.82) file...")
+3 ;
+4 ; verify IEN of OUTPATIENT program in FEE BASIS PROGRAM file
+5 IF $PIECE($GET(^FBAA(161.8,2,0)),U)'="OUTPATIENT"
Begin DoDot:1
+6 DO MES^XPDUTL(" ERROR: Fee Program with IEN 2 is not OUTPATIENT.")
+7 DO MES^XPDUTL(" Purpose of Visits could not be updated.")
End DoDot:1
QUIT
+8 ;
+9 ; update POVs
+10 KILL FBFDA
+11 ; loop thru POVs
+12 FOR FBI=1:1
SET FBX=$PIECE($TEXT(POV+FBI),";;",2)
if FBX="END"
QUIT
Begin DoDot:1
+13 SET FBCODE=$PIECE(FBX,U)
+14 SET FBNAME=$PIECE(FBX,U,2)
+15 SET FBPROG=$PIECE(FBX,U,3)
+16 ;
+17 ; locate POV in file
+18 SET FBDA=$$FIND1^DIC(161.82,"","X",FBCODE,"AC")
+19 ;
+20 ; if POV found then check and if necessary add to update array
+21 IF FBDA
Begin DoDot:2
+22 IF $$GET1^DIQ(161.82,FBDA_",",.01)'=FBNAME
SET FBFDA(161.82,FBDA_",",.01)=FBNAME
+23 IF $$GET1^DIQ(161.82,FBDA_",",2,"I")'=FBPROG
SET FBFDA(161.82,FBDA_",",2)=FBPROG
End DoDot:2
+24 ;
+25 ; if POV not found then add it
+26 IF 'FBDA
Begin DoDot:2
+27 NEW DA,DD,DIC,DINUM,DLAYGO,DO,X
+28 SET DIC="^FBAA(161.82,"
SET DIC(0)="L"
SET DLAYGO=161.82
+29 SET X=FBNAME
if X=""
QUIT
+30 SET DIC("DR")="2////^S X=FBPROG;3////^S X=FBCODE"
+31 IF +FBCODE
IF '$DATA(^FBAA(161.82,+FBCODE,0))
SET DINUM=+FBCODE
+32 DO FILE^DICN
+33 IF Y<0
DO MES^XPDUTL("ERROR ADDING POV WITH CODE "_FBCODE)
End DoDot:2
End DoDot:1
+34 ;
+35 ; actually update the found POVs
+36 IF $DATA(FBFDA)
DO FILE^DIE("","FBFDA")
+37 ;
+38 DO MES^XPDUTL(" Done.")
+39 QUIT
+40 ;
POV ;austin code^name^fee program for Purpose of Visit (POV) code(s)
+1 ;;75^CHIROPRACTIC CARE^2
+2 ;;END
+3 ;
VENDOR ;Update Vendor Codes
+1 NEW FBDT,FBNOW
+2 ; effective date/time for PART and SPEC updates
SET FBDT="3010103.22"
+3 ; current date/time
SET FBNOW=$$NOW^XLFDT()
+4 ;
+5 IF FBDT>FBNOW
Begin DoDot:1
+6 ; Queue task for FBDT since effective date/time is future
+7 NEW ZTSK
+8 SET ZTRTN="ENQ^FBAAUVC"
+9 SET ZTDESC="FEE BASIS UPDATE OF PART. AND SPEC. VENDOR CODES"
+10 SET ZTDTH=FBDT
+11 SET ZTIO=""
+12 DO ^%ZTLOAD
+13 ;
+14 IF '$GET(ZTSK)
Begin DoDot:2
+15 DO BMES^XPDUTL("ERROR. The task was not successfully queued.")
+16 DO MES^XPDUTL("Please contact National VISTA Support for assistance.")
End DoDot:2
+17 ;
+18 IF $GET(ZTSK)
Begin DoDot:2
+19 DO BMES^XPDUTL(" The task to update the PARTICIPATION CODE and the")
+20 DO MES^XPDUTL(" SPECIALTY CODE was successfully queued.")
+21 DO MES^XPDUTL(" The task number is "_ZTSK)
+22 DO MES^XPDUTL(" It will start on "_$$HTE^XLFDT(ZTSK("D")))
End DoDot:2
End DoDot:1
+23 ;
+24 IF FBDT'>FBNOW
Begin DoDot:1
+25 ; perform update now since effective date has already past
+26 NEW FBERR
+27 ;
+28 DO BMES^XPDUTL(" Updating selected codes in the FEE BASIS PARTICIPATION CODE (161.81) file...")
+29 DO UPDPART^FBAAUVC
+30 IF $DATA(FBERR)
Begin DoDot:2
+31 NEW FBCODE
+32 SET FBCODE=""
FOR
SET FBCODE=$ORDER(FBERR(FBCODE))
if FBCODE=""
QUIT
Begin DoDot:3
+33 DO MES^XPDUTL("ERROR ADDING PART CODE "_FBCODE)
End DoDot:3
End DoDot:2
+34 DO MES^XPDUTL(" Done.")
+35 ;
+36 DO BMES^XPDUTL(" Updating selected Codes in the FEE BASIS SPECIALTY CODE (161.6) file...")
+37 DO UPDSPEC^FBAAUVC
+38 IF $DATA(FBERR)
Begin DoDot:2
+39 NEW FBCODE
+40 SET FBCODE=""
FOR
SET FBCODE=$ORDER(FBERR(FBCODE))
if FBCODE=""
QUIT
Begin DoDot:3
+41 DO MES^XPDUTL("ERROR ADDING SPECIALTY CODE "_FBCODE)
End DoDot:3
End DoDot:2
+42 DO MES^XPDUTL(" Done.")
End DoDot:1
+43 ;
+44 ;FBXIP24
