IBY732PO ;AITC/DTG - Post-Installation for IB patch 732; MAR 30, 2022
;;2.0;INTEGRATED BILLING;**732**;MAR 21,1994;Build 13
;;Per VA Directive 6402, this routine should not be modified.
;
; Reference to $$INSTALDT^XPDUTL in ICR #10141
; Reference to %ZTLOAD in ICR #10063
; Reference to $$FMADD^XLFDT in ICR #10103
Q
;
POST ; POST-INSTALL
N IBINSTLD,IBXPD,SITE,SITENAME,SITENUM,XPDIDTOT
S IBPOSITION="!?((IOM/2)-($L(A)/2))" ;IB718
; total number of work items
S XPDIDTOT=3
;
S SITE=$$SITE^VASITE,SITENAME=$P(SITE,U,2),SITENUM=$P(SITE,U,3)
;
S IBINSTLD=$$INSTALDT^XPDUTL("IB*2.0*732","")
D MES^XPDUTL("")
;
D PLAN(1) ; added VISION to PLAN LIMITATION CATEGORY file (#355.31)
;
D WRK(2) ; fix from 718
;
D SITEREG(3,SITENUM) ; Send site registration message to FSC ;
;
D MES^XPDUTL("") ; Displays the 'Done' message and finishes the progress bar
D MES^XPDUTL("POST-Install for IB*2.0*732 Completed.")
Q
;============================
;
;
PLAN(IBXPD) ; add Vision to Plan Coverage Limitations
S IBXPD=$G(IBXPD),XPDIDTOT=$G(XPDIDTOT)
D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
D MES^XPDUTL("-------------")
;
N DA,DD,DIC,DIE,DLAYGO,DO,DR,X,Y
N IBA,IBDA,IBFILE,IBFND,IBNAME
;
S IBNAME="VISION",IBFILE="PLAN LIMITATION CATEGORY (#355.31)"
D MES^XPDUTL("Adding "_IBNAME_" to the "_IBFILE)
;
S IBFND=0
I $O(^IBE(355.31,"B",IBNAME,0)) S IBFND=1
I $G(IBFND)=1 D MES^XPDUTL("*** "_IBNAME_" not added to "_IBFILE_" ALREADY EXISTS ***") G PLANQ
;
S DLAYGO=355.31,DIC="^IBE(355.31,",DIC(0)="L",X=IBNAME
D FILE^DICN K DIC
S IBDA=+Y I Y<1 K X,Y D G PLANQ
. D MES^XPDUTL("*** "_IBNAME_" not added to "_IBFILE_" NOT able to create entry ***")
;
S DIE="^IBE(355.31,",DA=+IBDA,DR=".02///Vision coverage"
D ^DIE
;
D MES^XPDUTL("Vision Plan was added.....")
;
PLANQ ; plan add exit
;
K DIE,DA,DR,X,Y
Q
;
WRK(IBXPD) ; FROM 718
;
S IBXPD=$G(IBXPD),XPDIDTOT=$G(XPDIDTOT)
D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
D MES^XPDUTL("-------------")
;
N IBIEN,IBGLBROOT,IBFILENUM,IBFDA,LOCALIEN,LOCALIENS
N IBFLAGS,IBFIELD,IBWPROOT,IBWPERROR,IBNAME01,IBCODE
;
;XPDGREF = ^XTMP("XPDI",INSTALL_IEN,"TEMP")
;XPDNM = "ZZ*1.0*732"
;
S IBFILENUM=$QS($Q(@XPDGREF),5)
S IBIEN=0
F S IBIEN=$O(@XPDGREF@(XPDNM,IBFILENUM,IBIEN)) Q:'IBIEN D
.S IBNAME01=$P($G(@XPDGREF@(XPDNM,IBFILENUM,IBIEN,0)),U) ;NAME
.S IBCODE=$P($G(@XPDGREF@(XPDNM,IBFILENUM,IBIEN,0)),U,2) ;CODE
.;
.S LOCALIEN=$$FINDLOCALIEN(IBNAME01,IBFILENUM,IBCODE) ;FIND THE LOCAL ENTRY IEN WE NEED TO MODIFY
.Q:'LOCALIEN ;IF NO DISTINCT IEN FOUND DO NOT TRY AND MODIFY
.;
.S LOCALIENS=LOCALIEN_","
.;JUST UPDATING THE HELP PROMPT
.;WORD PROCESSING FIELD MUST BE DONE BY WP^DIE
.S IBFIELD=1
.S IBFLAGS=""
.K IBWPROOT
.M IBWPROOT=@XPDGREF@(XPDNM,IBFILENUM,IBIEN,1)
.K IBWPROOT(0)
.S IBWPROOT="IBWPROOT"
.;
.D WP^DIE(IBFILENUM,LOCALIENS,IBFIELD,IBFLAGS,"IBWPROOT","IBWPERROR") ;^DGCR(399.1,D0,1,D1,0)= (#.01) VALUE CODE HELP TEXT [1W]
.;
.I $D(IBWPERROR) D
..D BMES^XPDUTL("Problem modifying Word Processing routine for "_NAME01_" in file "_IBFILENUM)
.;
;
D BMES^XPDUTL("Finished modifying Entries to "_$G(IBFILENUM)_" File")
;
FINDLOCALIEN(NAME01,FILENUM,IBCODE) ;FIND THE LOCAL IEN WE NEED TO MODIFY
N RETURN,ERROR,INDEX,LOCALIEN,MATCHIEN
S INDEX="M"
D FIND^DIC(FILENUM,"","","",NAME01,INDEX,,,,"RETURN","ERROR")
;
I $D(ERROR) D Q 0
.D BMES^XPDUTL("*** Error when searching for "_NAME01_" in file "_FILENUM_"***")
;
I '$D(RETURN) D Q 0
.D BMES^XPDUTL("*** Entry "_NAME01_" in file "_FILENUM_"not found ***")
;
I $P($G(RETURN("DILIST",0)),U)>1 D
.D BMES^XPDUTL("*** Duplicate entries found for "_NAME01_" in file "_FILENUM_"***")
.D BMES^XPDUTL("*** Using CODE '"_$G(IBCODE)_"' to determine correct record to update.***")
.;CHECK FIELD #.18 VALUE CODE 0^NODE P^11
.S MATCHIEN=$$MATCHCODE(.RETURN,IBCODE)
.S LOCALIEN=$P($G(RETURN("DILIST",2,MATCHIEN)),U)
;
;AT THIS POINT WE HAVE FOUND ONE ENTRY AND WE CAN MODIFY IT
S:$G(LOCALIEN)="" LOCALIEN=$P($G(RETURN("DILIST",2,1)),U)
Q LOCALIEN
;
MATCHCODE(RETURN,IBCODE) ;EP - RETURN LOCAL IEN MATCHING NAME AND CODE OF INCOMING VALUE CODE ENTRY
N IEN,MATCH
S MATCH=0
S IEN=0
F S IEN=$O(RETURN("DILIST","ID",IEN)) Q:'IEN D Q:$G(MATCH)
.I IBCODE=RETURN("DILIST","ID",IEN,.02) S MATCH=IEN
;
I 'MATCH D
.D BMES^XPDUTL("No distinct match for Value Code "_$G(IBCODE)_" when duplicate records found!")
Q MATCH
;
;
SITEREG(IBXPD,SITENUM) ; send site registration message to FSC
D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
D MES^XPDUTL("-------------")
D MES^XPDUTL("Send eIV site registration message to FSC ... ")
;
I '$$PROD^XUPROD(1) D MES^XPDUTL("N/A - Not a production account - No site registration message sent") G SITEREGQ
I SITENUM=358 D MES^XPDUTL("Current Site is MANILA - NO eIV site registration message sent") G SITEREGQ
D ^IBCNEHLM
D MES^XPDUTL("eIV site registration message was successfully sent")
;
SITEREGQ ;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBY732PO 5110 printed Nov 22, 2024@17:45:16 Page 2
IBY732PO ;AITC/DTG - Post-Installation for IB patch 732; MAR 30, 2022
+1 ;;2.0;INTEGRATED BILLING;**732**;MAR 21,1994;Build 13
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference to $$INSTALDT^XPDUTL in ICR #10141
+5 ; Reference to %ZTLOAD in ICR #10063
+6 ; Reference to $$FMADD^XLFDT in ICR #10103
+7 QUIT
+8 ;
POST ; POST-INSTALL
+1 NEW IBINSTLD,IBXPD,SITE,SITENAME,SITENUM,XPDIDTOT
+2 ;IB718
SET IBPOSITION="!?((IOM/2)-($L(A)/2))"
+3 ; total number of work items
+4 SET XPDIDTOT=3
+5 ;
+6 SET SITE=$$SITE^VASITE
SET SITENAME=$PIECE(SITE,U,2)
SET SITENUM=$PIECE(SITE,U,3)
+7 ;
+8 SET IBINSTLD=$$INSTALDT^XPDUTL("IB*2.0*732","")
+9 DO MES^XPDUTL("")
+10 ;
+11 ; added VISION to PLAN LIMITATION CATEGORY file (#355.31)
DO PLAN(1)
+12 ;
+13 ; fix from 718
DO WRK(2)
+14 ;
+15 ; Send site registration message to FSC ;
DO SITEREG(3,SITENUM)
+16 ;
+17 ; Displays the 'Done' message and finishes the progress bar
DO MES^XPDUTL("")
+18 DO MES^XPDUTL("POST-Install for IB*2.0*732 Completed.")
+19 QUIT
+20 ;============================
+21 ;
+22 ;
PLAN(IBXPD) ; add Vision to Plan Coverage Limitations
+1 SET IBXPD=$GET(IBXPD)
SET XPDIDTOT=$GET(XPDIDTOT)
+2 DO BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
+3 DO MES^XPDUTL("-------------")
+4 ;
+5 NEW DA,DD,DIC,DIE,DLAYGO,DO,DR,X,Y
+6 NEW IBA,IBDA,IBFILE,IBFND,IBNAME
+7 ;
+8 SET IBNAME="VISION"
SET IBFILE="PLAN LIMITATION CATEGORY (#355.31)"
+9 DO MES^XPDUTL("Adding "_IBNAME_" to the "_IBFILE)
+10 ;
+11 SET IBFND=0
+12 IF $ORDER(^IBE(355.31,"B",IBNAME,0))
SET IBFND=1
+13 IF $GET(IBFND)=1
DO MES^XPDUTL("*** "_IBNAME_" not added to "_IBFILE_" ALREADY EXISTS ***")
GOTO PLANQ
+14 ;
+15 SET DLAYGO=355.31
SET DIC="^IBE(355.31,"
SET DIC(0)="L"
SET X=IBNAME
+16 DO FILE^DICN
KILL DIC
+17 SET IBDA=+Y
IF Y<1
KILL X,Y
Begin DoDot:1
+18 DO MES^XPDUTL("*** "_IBNAME_" not added to "_IBFILE_" NOT able to create entry ***")
End DoDot:1
GOTO PLANQ
+19 ;
+20 SET DIE="^IBE(355.31,"
SET DA=+IBDA
SET DR=".02///Vision coverage"
+21 DO ^DIE
+22 ;
+23 DO MES^XPDUTL("Vision Plan was added.....")
+24 ;
PLANQ ; plan add exit
+1 ;
+2 KILL DIE,DA,DR,X,Y
+3 QUIT
+4 ;
WRK(IBXPD) ; FROM 718
+1 ;
+2 SET IBXPD=$GET(IBXPD)
SET XPDIDTOT=$GET(XPDIDTOT)
+3 DO BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
+4 DO MES^XPDUTL("-------------")
+5 ;
+6 NEW IBIEN,IBGLBROOT,IBFILENUM,IBFDA,LOCALIEN,LOCALIENS
+7 NEW IBFLAGS,IBFIELD,IBWPROOT,IBWPERROR,IBNAME01,IBCODE
+8 ;
+9 ;XPDGREF = ^XTMP("XPDI",INSTALL_IEN,"TEMP")
+10 ;XPDNM = "ZZ*1.0*732"
+11 ;
+12 SET IBFILENUM=$QSUBSCRIPT($QUERY(@XPDGREF),5)
+13 SET IBIEN=0
+14 FOR
SET IBIEN=$ORDER(@XPDGREF@(XPDNM,IBFILENUM,IBIEN))
if 'IBIEN
QUIT
Begin DoDot:1
+15 ;NAME
SET IBNAME01=$PIECE($GET(@XPDGREF@(XPDNM,IBFILENUM,IBIEN,0)),U)
+16 ;CODE
SET IBCODE=$PIECE($GET(@XPDGREF@(XPDNM,IBFILENUM,IBIEN,0)),U,2)
+17 ;
+18 ;FIND THE LOCAL ENTRY IEN WE NEED TO MODIFY
SET LOCALIEN=$$FINDLOCALIEN(IBNAME01,IBFILENUM,IBCODE)
+19 ;IF NO DISTINCT IEN FOUND DO NOT TRY AND MODIFY
if 'LOCALIEN
QUIT
+20 ;
+21 SET LOCALIENS=LOCALIEN_","
+22 ;JUST UPDATING THE HELP PROMPT
+23 ;WORD PROCESSING FIELD MUST BE DONE BY WP^DIE
+24 SET IBFIELD=1
+25 SET IBFLAGS=""
+26 KILL IBWPROOT
+27 MERGE IBWPROOT=@XPDGREF@(XPDNM,IBFILENUM,IBIEN,1)
+28 KILL IBWPROOT(0)
+29 SET IBWPROOT="IBWPROOT"
+30 ;
+31 ;^DGCR(399.1,D0,1,D1,0)= (#.01) VALUE CODE HELP TEXT [1W]
DO WP^DIE(IBFILENUM,LOCALIENS,IBFIELD,IBFLAGS,"IBWPROOT","IBWPERROR")
+32 ;
+33 IF $DATA(IBWPERROR)
Begin DoDot:2
+34 DO BMES^XPDUTL("Problem modifying Word Processing routine for "_NAME01_" in file "_IBFILENUM)
End DoDot:2
+35 ;
End DoDot:1
+36 ;
+37 DO BMES^XPDUTL("Finished modifying Entries to "_$GET(IBFILENUM)_" File")
+38 ;
FINDLOCALIEN(NAME01,FILENUM,IBCODE) ;FIND THE LOCAL IEN WE NEED TO MODIFY
+1 NEW RETURN,ERROR,INDEX,LOCALIEN,MATCHIEN
+2 SET INDEX="M"
+3 DO FIND^DIC(FILENUM,"","","",NAME01,INDEX,,,,"RETURN","ERROR")
+4 ;
+5 IF $DATA(ERROR)
Begin DoDot:1
+6 DO BMES^XPDUTL("*** Error when searching for "_NAME01_" in file "_FILENUM_"***")
End DoDot:1
QUIT 0
+7 ;
+8 IF '$DATA(RETURN)
Begin DoDot:1
+9 DO BMES^XPDUTL("*** Entry "_NAME01_" in file "_FILENUM_"not found ***")
End DoDot:1
QUIT 0
+10 ;
+11 IF $PIECE($GET(RETURN("DILIST",0)),U)>1
Begin DoDot:1
+12 DO BMES^XPDUTL("*** Duplicate entries found for "_NAME01_" in file "_FILENUM_"***")
+13 DO BMES^XPDUTL("*** Using CODE '"_$GET(IBCODE)_"' to determine correct record to update.***")
+14 ;CHECK FIELD #.18 VALUE CODE 0^NODE P^11
+15 SET MATCHIEN=$$MATCHCODE(.RETURN,IBCODE)
+16 SET LOCALIEN=$PIECE($GET(RETURN("DILIST",2,MATCHIEN)),U)
End DoDot:1
+17 ;
+18 ;AT THIS POINT WE HAVE FOUND ONE ENTRY AND WE CAN MODIFY IT
+19 if $GET(LOCALIEN)=""
SET LOCALIEN=$PIECE($GET(RETURN("DILIST",2,1)),U)
+20 QUIT LOCALIEN
+21 ;
MATCHCODE(RETURN,IBCODE) ;EP - RETURN LOCAL IEN MATCHING NAME AND CODE OF INCOMING VALUE CODE ENTRY
+1 NEW IEN,MATCH
+2 SET MATCH=0
+3 SET IEN=0
+4 FOR
SET IEN=$ORDER(RETURN("DILIST","ID",IEN))
if 'IEN
QUIT
Begin DoDot:1
+5 IF IBCODE=RETURN("DILIST","ID",IEN,.02)
SET MATCH=IEN
End DoDot:1
if $GET(MATCH)
QUIT
+6 ;
+7 IF 'MATCH
Begin DoDot:1
+8 DO BMES^XPDUTL("No distinct match for Value Code "_$GET(IBCODE)_" when duplicate records found!")
End DoDot:1
+9 QUIT MATCH
+10 ;
+11 ;
SITEREG(IBXPD,SITENUM) ; send site registration message to FSC
+1 DO BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
+2 DO MES^XPDUTL("-------------")
+3 DO MES^XPDUTL("Send eIV site registration message to FSC ... ")
+4 ;
+5 IF '$$PROD^XUPROD(1)
DO MES^XPDUTL("N/A - Not a production account - No site registration message sent")
GOTO SITEREGQ
+6 IF SITENUM=358
DO MES^XPDUTL("Current Site is MANILA - NO eIV site registration message sent")
GOTO SITEREGQ
+7 DO ^IBCNEHLM
+8 DO MES^XPDUTL("eIV site registration message was successfully sent")
+9 ;
SITEREGQ ;
+1 QUIT
+2 ;
