FBXIP39 ;WOIFO/SS-PATCH INSTALL ROUTINE ;7/13/01
;;3.5;FEE BASIS;**39**;JAN 30, 1995
;File #161.2 conversion routine
Q ;stub
;/**
;post-install entry point
EN39 ;*/
D KILTMP
I $$PATCH^XPDUTL("FB*3.5*39") D BMES^XPDUTL(" Skipping Vendor file conversion since patch was previously installed.") Q
N FBQCNT,FBRVCNT,FBCNT S (FBQCNT,FBRVCNT,FBCNT)=0 ;counters
D TMPGL
D BMES^XPDUTL(" Processing Q-code: "_FBQCNT_" entries.")
D QCODE
D BMES^XPDUTL(" Processing RV-code: "_FBRVCNT_" entries.")
D RVCODE
D BMES^XPDUTL(" Marked to be sent to Austin for update: "_FBCNT_" entries.")
D NMARKED
D KILTMP
Q
;/**
;kills ^TMP
KILTMP ;*/
K ^TMP($J,"FBXIPQR")
K ^TMP($J,"FBXIP39")
Q
;/**
;TMPGL
;Create ^TMP with all essential codes
TMPGL ;*/
N FBIEN,FBN,FBQ,FBRV,FBFPDS
S FBQ=158 ;Q-code
S FBRV=167 ;RV-code
S FBIEN=0
F S FBIEN=$O(^FBAAV(FBIEN)) Q:'FBIEN D
. Q:$P($G(^FBAAV(FBIEN,2,0)),"^",4)<1
. S FBN=0
. F S FBN=$O(^FBAAV(FBIEN,2,FBN)) Q:'FBN D
. . S FBFPDS=$G(^FBAAV(FBIEN,2,FBN,0))
. . I FBFPDS=FBRV S ^TMP($J,"FBXIPQR",FBFPDS,FBIEN)=FBN,FBRVCNT=FBRVCNT+1 Q
. . I FBFPDS=FBQ S ^TMP($J,"FBXIPQR",FBFPDS,FBIEN)=FBN,FBQCNT=FBQCNT+1 Q
Q
;
;
;/**
;QCODE
;For all vendors with Q-code do the following:
;1) add to correction file to inform Austin about changes
;2) delete "Q"- code
;3) if there is no "S" code for the vendor - add "S" code
; but only if it is SMALL BUSINESS type
QCODE ;*/
N FBIEN,FBQ,FBS
S FBQ=158 ;Q-code
S FBS=162 ;S-code
S FBIEN=0
F S FBIEN=$O(^TMP($J,"FBXIPQR",FBQ,FBIEN)) Q:'FBIEN D
. D ADDCORR(FBIEN) ;add to correction file
. D CHNGITEM(FBIEN,$G(^TMP($J,"FBXIPQR",FBQ,FBIEN)),"@")
. ;if business type (fpds) null or not Small Business
. I $P($G(^FBAAV(FBIEN,1)),"^",10)'=1 Q
. I $O(^FBAAV(FBIEN,2,"B",FBS,0))'="" Q
. D INSITEM(FBIEN,FBS)
Q
;
;/**
;RVCODE
;For all vendors with RV-code do the following:
;1) add to correction file to inform Austin
RVCODE ;*/
N FBIEN,FBRV
S FBRV=167 ;RV-code
S FBIEN=0
F S FBIEN=$O(^TMP($J,"FBXIPQR",FBRV,FBIEN)) Q:'FBIEN D
. D ADDCORR(FBIEN) ;add to correction file
Q
;
;/**
;ADDCORR
;Add vendors with changes to correction file (#161.25)
;
ADDCORR(FBIEN) ;*/
;if business type (fpds) null
I $P($G(^FBAAV(FBIEN,1)),"^",10)="" Q
;
;if Austin deleted
I $P($G(^FBAAV(FBIEN,"ADEL")),"^")="Y" Q
;
;if linked to another vendor
N FBDA1 S FBDA1=$O(^FBAA(161.25,"AF",FBIEN,0))
I FBDA1]"",FBDA1'=FBIEN Q ;linked to another vendor
;
;if vendor already in 161.25
I $D(^FBAA(161.25,FBIEN)) D Q
. ;
. ;not place the entry - previous change was not transmitted yet,
. ;will be transmitted with new fpds
. I $P($G(^FBAA(161.25,FBIEN,0)),"^",5)="" S FBCNT=$$FBCNTINC() Q
. ;
. ;save it for a list of non-processed
. ;vendors. Previous change was transmitted to
. ;Austin but there is no reply for the change from Austin yet,
. ;so at the moment we cannot perform new transmission to Austin
. S ^TMP($J,"FBXIP39",FBIEN)=""
. Q
;if it is already marked
Q:$D(FBCNT(FBIEN))
;otherwise file it
N FEEO,FBT,FBIEN1,DA S (DA,FBIEN1)=FBIEN,FBT="F",FEEO="" D SETGL^FBAAVD
S FBCNT=$$FBCNTINC()
Q
;
;/**
;Counter for marked vendors
;
FBCNTINC() ;*/
Q:$D(FBCNT(FBIEN)) FBCNT
S FBCNT(FBIEN)=""
Q FBCNT+1
;
;/**
;CHNGITEM
;change or delete FPDS code
CHNGITEM(FBIEN,FBN,FBCOD) ;*/
N FBIENS,FBFDA
S FBIENS=FBN_","_FBIEN_","
S FBFDA(161.225,FBIENS,.01)=FBCOD
D FILE^DIE("","FBFDA")
Q
;
;/**
;INSITEM
;insert FPDS code
INSITEM(FBIEN,FBCOD) ;*/
N FBSSI,FBIENS,FBFDA,FBER
S FBIENS="+1,"_FBIEN_","
S FBFDA(161.225,FBIENS,.01)=FBCOD
D UPDATE^DIE("","FBFDA","FBSSI","FBER")
I $D(FBER) D BMES^XPDUTL(FBER("DIERR",1,"TEXT",1))
Q
;
;/**
;print all vendors that were not marked to sent to Austin
;
NMARKED ;*/
Q:'$D(^TMP($J,"FBXIP39"))
N FBDT,FBID,FBVEN,FBX,FB,FBY,FBDA
D BMES^XPDUTL(" The following vendors could not be marked for transmission")
D MES^XPDUTL(" because they are currently awaiting Austin action.")
D BMES^XPDUTL(" Vendor Name ID Sent to Austin")
D MES^XPDUTL(" ---------------------------------------- ----------- --------------")
S FBDA=0 F S FBDA=$O(^TMP($J,"FBXIP39",FBDA)) Q:'FBDA D
. S FBY(0)=$G(^FBAAV(FBDA,0))
. S FBVEN=$E($P(FBY(0),"^"),1,40)
. S FBID=$P(FBY(0),"^",2)
. S FBDT=$P($G(^FBAAV(FBDA,"ADEL")),"^",2)
. I FBDT]"" S FBDT=$$FMTE^XLFDT(FBDT)
. S FBX=" "_$$LJ^XLFSTR(FBVEN,42)_$$LJ^XLFSTR(FBID,13)_FBDT
. D MES^XPDUTL(FBX)
D BMES^XPDUTL(" The Update FMS Vendor File in Austin [FBAA FMS UPDATE] option can be")
D MES^XPDUTL(" used to send the socio-economic data for the listed vendors to")
D MES^XPDUTL(" Austin after their current pending action has been resolved.")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBXIP39 4888 printed Sep 23, 2025@19:37:53 Page 2
FBXIP39 ;WOIFO/SS-PATCH INSTALL ROUTINE ;7/13/01
+1 ;;3.5;FEE BASIS;**39**;JAN 30, 1995
+2 ;File #161.2 conversion routine
+3 ;stub
QUIT
+4 ;/**
+5 ;post-install entry point
EN39 ;*/
+1 DO KILTMP
+2 IF $$PATCH^XPDUTL("FB*3.5*39")
DO BMES^XPDUTL(" Skipping Vendor file conversion since patch was previously installed.")
QUIT
+3 ;counters
NEW FBQCNT,FBRVCNT,FBCNT
SET (FBQCNT,FBRVCNT,FBCNT)=0
+4 DO TMPGL
+5 DO BMES^XPDUTL(" Processing Q-code: "_FBQCNT_" entries.")
+6 DO QCODE
+7 DO BMES^XPDUTL(" Processing RV-code: "_FBRVCNT_" entries.")
+8 DO RVCODE
+9 DO BMES^XPDUTL(" Marked to be sent to Austin for update: "_FBCNT_" entries.")
+10 DO NMARKED
+11 DO KILTMP
+12 QUIT
+13 ;/**
+14 ;kills ^TMP
KILTMP ;*/
+1 KILL ^TMP($JOB,"FBXIPQR")
+2 KILL ^TMP($JOB,"FBXIP39")
+3 QUIT
+4 ;/**
+5 ;TMPGL
+6 ;Create ^TMP with all essential codes
TMPGL ;*/
+1 NEW FBIEN,FBN,FBQ,FBRV,FBFPDS
+2 ;Q-code
SET FBQ=158
+3 ;RV-code
SET FBRV=167
+4 SET FBIEN=0
+5 FOR
SET FBIEN=$ORDER(^FBAAV(FBIEN))
if 'FBIEN
QUIT
Begin DoDot:1
+6 if $PIECE($GET(^FBAAV(FBIEN,2,0)),"^",4)<1
QUIT
+7 SET FBN=0
+8 FOR
SET FBN=$ORDER(^FBAAV(FBIEN,2,FBN))
if 'FBN
QUIT
Begin DoDot:2
+9 SET FBFPDS=$GET(^FBAAV(FBIEN,2,FBN,0))
+10 IF FBFPDS=FBRV
SET ^TMP($JOB,"FBXIPQR",FBFPDS,FBIEN)=FBN
SET FBRVCNT=FBRVCNT+1
QUIT
+11 IF FBFPDS=FBQ
SET ^TMP($JOB,"FBXIPQR",FBFPDS,FBIEN)=FBN
SET FBQCNT=FBQCNT+1
QUIT
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
+14 ;
+15 ;/**
+16 ;QCODE
+17 ;For all vendors with Q-code do the following:
+18 ;1) add to correction file to inform Austin about changes
+19 ;2) delete "Q"- code
+20 ;3) if there is no "S" code for the vendor - add "S" code
+21 ; but only if it is SMALL BUSINESS type
QCODE ;*/
+1 NEW FBIEN,FBQ,FBS
+2 ;Q-code
SET FBQ=158
+3 ;S-code
SET FBS=162
+4 SET FBIEN=0
+5 FOR
SET FBIEN=$ORDER(^TMP($JOB,"FBXIPQR",FBQ,FBIEN))
if 'FBIEN
QUIT
Begin DoDot:1
+6 ;add to correction file
DO ADDCORR(FBIEN)
+7 DO CHNGITEM(FBIEN,$GET(^TMP($JOB,"FBXIPQR",FBQ,FBIEN)),"@")
+8 ;if business type (fpds) null or not Small Business
+9 IF $PIECE($GET(^FBAAV(FBIEN,1)),"^",10)'=1
QUIT
+10 IF $ORDER(^FBAAV(FBIEN,2,"B",FBS,0))'=""
QUIT
+11 DO INSITEM(FBIEN,FBS)
End DoDot:1
+12 QUIT
+13 ;
+14 ;/**
+15 ;RVCODE
+16 ;For all vendors with RV-code do the following:
+17 ;1) add to correction file to inform Austin
RVCODE ;*/
+1 NEW FBIEN,FBRV
+2 ;RV-code
SET FBRV=167
+3 SET FBIEN=0
+4 FOR
SET FBIEN=$ORDER(^TMP($JOB,"FBXIPQR",FBRV,FBIEN))
if 'FBIEN
QUIT
Begin DoDot:1
+5 ;add to correction file
DO ADDCORR(FBIEN)
End DoDot:1
+6 QUIT
+7 ;
+8 ;/**
+9 ;ADDCORR
+10 ;Add vendors with changes to correction file (#161.25)
+11 ;
ADDCORR(FBIEN) ;*/
+1 ;if business type (fpds) null
+2 IF $PIECE($GET(^FBAAV(FBIEN,1)),"^",10)=""
QUIT
+3 ;
+4 ;if Austin deleted
+5 IF $PIECE($GET(^FBAAV(FBIEN,"ADEL")),"^")="Y"
QUIT
+6 ;
+7 ;if linked to another vendor
+8 NEW FBDA1
SET FBDA1=$ORDER(^FBAA(161.25,"AF",FBIEN,0))
+9 ;linked to another vendor
IF FBDA1]""
IF FBDA1'=FBIEN
QUIT
+10 ;
+11 ;if vendor already in 161.25
+12 IF $DATA(^FBAA(161.25,FBIEN))
Begin DoDot:1
+13 ;
+14 ;not place the entry - previous change was not transmitted yet,
+15 ;will be transmitted with new fpds
+16 IF $PIECE($GET(^FBAA(161.25,FBIEN,0)),"^",5)=""
SET FBCNT=$$FBCNTINC()
QUIT
+17 ;
+18 ;save it for a list of non-processed
+19 ;vendors. Previous change was transmitted to
+20 ;Austin but there is no reply for the change from Austin yet,
+21 ;so at the moment we cannot perform new transmission to Austin
+22 SET ^TMP($JOB,"FBXIP39",FBIEN)=""
+23 QUIT
End DoDot:1
QUIT
+24 ;if it is already marked
+25 if $DATA(FBCNT(FBIEN))
QUIT
+26 ;otherwise file it
+27 NEW FEEO,FBT,FBIEN1,DA
SET (DA,FBIEN1)=FBIEN
SET FBT="F"
SET FEEO=""
DO SETGL^FBAAVD
+28 SET FBCNT=$$FBCNTINC()
+29 QUIT
+30 ;
+31 ;/**
+32 ;Counter for marked vendors
+33 ;
FBCNTINC() ;*/
+1 if $DATA(FBCNT(FBIEN))
QUIT FBCNT
+2 SET FBCNT(FBIEN)=""
+3 QUIT FBCNT+1
+4 ;
+5 ;/**
+6 ;CHNGITEM
+7 ;change or delete FPDS code
CHNGITEM(FBIEN,FBN,FBCOD) ;*/
+1 NEW FBIENS,FBFDA
+2 SET FBIENS=FBN_","_FBIEN_","
+3 SET FBFDA(161.225,FBIENS,.01)=FBCOD
+4 DO FILE^DIE("","FBFDA")
+5 QUIT
+6 ;
+7 ;/**
+8 ;INSITEM
+9 ;insert FPDS code
INSITEM(FBIEN,FBCOD) ;*/
+1 NEW FBSSI,FBIENS,FBFDA,FBER
+2 SET FBIENS="+1,"_FBIEN_","
+3 SET FBFDA(161.225,FBIENS,.01)=FBCOD
+4 DO UPDATE^DIE("","FBFDA","FBSSI","FBER")
+5 IF $DATA(FBER)
DO BMES^XPDUTL(FBER("DIERR",1,"TEXT",1))
+6 QUIT
+7 ;
+8 ;/**
+9 ;print all vendors that were not marked to sent to Austin
+10 ;
NMARKED ;*/
+1 if '$DATA(^TMP($JOB,"FBXIP39"))
QUIT
+2 NEW FBDT,FBID,FBVEN,FBX,FB,FBY,FBDA
+3 DO BMES^XPDUTL(" The following vendors could not be marked for transmission")
+4 DO MES^XPDUTL(" because they are currently awaiting Austin action.")
+5 DO BMES^XPDUTL(" Vendor Name ID Sent to Austin")
+6 DO MES^XPDUTL(" ---------------------------------------- ----------- --------------")
+7 SET FBDA=0
FOR
SET FBDA=$ORDER(^TMP($JOB,"FBXIP39",FBDA))
if 'FBDA
QUIT
Begin DoDot:1
+8 SET FBY(0)=$GET(^FBAAV(FBDA,0))
+9 SET FBVEN=$EXTRACT($PIECE(FBY(0),"^"),1,40)
+10 SET FBID=$PIECE(FBY(0),"^",2)
+11 SET FBDT=$PIECE($GET(^FBAAV(FBDA,"ADEL")),"^",2)
+12 IF FBDT]""
SET FBDT=$$FMTE^XLFDT(FBDT)
+13 SET FBX=" "_$$LJ^XLFSTR(FBVEN,42)_$$LJ^XLFSTR(FBID,13)_FBDT
+14 DO MES^XPDUTL(FBX)
End DoDot:1
+15 DO BMES^XPDUTL(" The Update FMS Vendor File in Austin [FBAA FMS UPDATE] option can be")
+16 DO MES^XPDUTL(" used to send the socio-economic data for the listed vendors to")
+17 DO MES^XPDUTL(" Austin after their current pending action has been resolved.")
+18 QUIT
+19 ;
