FBXIP36 ;WOIFO/SS-PATCH INSTALL ROUTINE ;7/13/01
;;3.5;FEE BASIS;**36**;JAN 30, 1995
;File #161.2 conversion routine
Q ;stub
;/**
;post-install entry point
EN36 ;*/
D KILTMP
I $$PATCH^XPDUTL("FB*3.5*36") D BMES^XPDUTL(" Skipping Vendor file conversion since patch was previously installed.") Q
N FBRCNT S FBRCNT=0 ;counters
D TMPGL
D BMES^XPDUTL(" Processing R-code: "_FBRCNT_" entries.")
D RCODE
D KILTMP
Q
;/**
;kills ^TMP
KILTMP ;*/
K ^TMP($J,"FBXIPQR")
Q
;/**
;TMPGL
;Create ^TMP with all essential codes
TMPGL ;*/
N FBIEN,FBN,FBR
S FBR=159 ;R-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:$G(^FBAAV(FBIEN,2,FBN,0))=FBR ^TMP($J,"FBXIPQR",FBR,FBIEN)=FBN,FBRCNT=FBRCNT+1
Q
;
;
;/**
;RCODE
;For all vendors with R-code do the following:
;1) delete "R"-code
;2) if there is no "S" code for the vendor - add "S" code
;3) insert "RV"-code
RCODE ;*/
N FBIEN,FBR,FBS,FBRV
S FBR=159 ;R-code
S FBS=162 ;S-code
S FBRV=167 ;RV-code
S FBIEN=0
F S FBIEN=$O(^TMP($J,"FBXIPQR",FBR,FBIEN)) Q:'FBIEN D
. D CHNGITEM(FBIEN,$G(^TMP($J,"FBXIPQR",FBR,FBIEN)),FBRV)
. I '$O(^FBAAV(FBIEN,2,"B",FBS,0)) D INSITEM(FBIEN,FBS)
Q
;
;/**
;CHNGITEM
;change 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
;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBXIP36 1766 printed Oct 16, 2024@18:02:34 Page 2
FBXIP36 ;WOIFO/SS-PATCH INSTALL ROUTINE ;7/13/01
+1 ;;3.5;FEE BASIS;**36**;JAN 30, 1995
+2 ;File #161.2 conversion routine
+3 ;stub
QUIT
+4 ;/**
+5 ;post-install entry point
EN36 ;*/
+1 DO KILTMP
+2 IF $$PATCH^XPDUTL("FB*3.5*36")
DO BMES^XPDUTL(" Skipping Vendor file conversion since patch was previously installed.")
QUIT
+3 ;counters
NEW FBRCNT
SET FBRCNT=0
+4 DO TMPGL
+5 DO BMES^XPDUTL(" Processing R-code: "_FBRCNT_" entries.")
+6 DO RCODE
+7 DO KILTMP
+8 QUIT
+9 ;/**
+10 ;kills ^TMP
KILTMP ;*/
+1 KILL ^TMP($JOB,"FBXIPQR")
+2 QUIT
+3 ;/**
+4 ;TMPGL
+5 ;Create ^TMP with all essential codes
TMPGL ;*/
+1 NEW FBIEN,FBN,FBR
+2 ;R-code
SET FBR=159
+3 SET FBIEN=0
+4 FOR
SET FBIEN=$ORDER(^FBAAV(FBIEN))
if 'FBIEN
QUIT
Begin DoDot:1
+5 if $PIECE($GET(^FBAAV(FBIEN,2,0)),"^",4)<1
QUIT
+6 SET FBN=0
+7 FOR
SET FBN=$ORDER(^FBAAV(FBIEN,2,FBN))
if 'FBN
QUIT
Begin DoDot:2
+8 if $GET(^FBAAV(FBIEN,2,FBN,0))=FBR
SET ^TMP($JOB,"FBXIPQR",FBR,FBIEN)=FBN
SET FBRCNT=FBRCNT+1
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
+11 ;
+12 ;/**
+13 ;RCODE
+14 ;For all vendors with R-code do the following:
+15 ;1) delete "R"-code
+16 ;2) if there is no "S" code for the vendor - add "S" code
+17 ;3) insert "RV"-code
RCODE ;*/
+1 NEW FBIEN,FBR,FBS,FBRV
+2 ;R-code
SET FBR=159
+3 ;S-code
SET FBS=162
+4 ;RV-code
SET FBRV=167
+5 SET FBIEN=0
+6 FOR
SET FBIEN=$ORDER(^TMP($JOB,"FBXIPQR",FBR,FBIEN))
if 'FBIEN
QUIT
Begin DoDot:1
+7 DO CHNGITEM(FBIEN,$GET(^TMP($JOB,"FBXIPQR",FBR,FBIEN)),FBRV)
+8 IF '$ORDER(^FBAAV(FBIEN,2,"B",FBS,0))
DO INSITEM(FBIEN,FBS)
End DoDot:1
+9 QUIT
+10 ;
+11 ;/**
+12 ;CHNGITEM
+13 ;change 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 ;
