IBY528PO ;ALB/CJS - Post install routine for patch 528 ;5-APR-15
;;2.0;INTEGRATED BILLING;**528**;21-MAR-94;Build 163
;;Per VA Directive 6402, this routine should not be modified.
;
Q
; This post-install routine will rename a security key; assign
; it to three additional menu options and an action protocol;
; and remove another security key from the three menu options.
;
; The name of the IBCNE IIV AUTO MATCH key will be changed to
; IBCNE EIV MAINTENANCE.
;
; The newly named IBCNE EIV MAINTENANCE key will be used to lock
; the following menu options in place of the current IB INSURANCE
; SUPERVISOR lock:
; IBCNE PAYER MAINTENANCE MENU
; IBCNE PAYER EDIT
; IBCNE PAYER LINK
;
; It will also be used to lock the Payer action (PA) action on
; the IBCN INSURANCE CO EDIT screen.
;
; Then this routine will also add a new user.
;
START ; CALL SECTIONS
D MES^XPDUTL(" Starting post-install for IB*2.0*528")
N IBY,Y
F IBY="KEYS","ADDUSR","COMMENTS","TYPE","SRCINF" D
. S Y=$$NEWCP^XPDUTL(IBY,IBY_"^IBY528PO")
. D:'Y BMES^XPDUTL("ERROR Creating "_IBY_" Checkpoint.")
; Completion message
D MES^XPDUTL(" Finished post-install for IB*2.0*528")
Q
;
KEYS ; Rename IBCNE IIV AUTO MATCH security key to IBCNE EIV MAINTENANCE
N IBFLAG,IBOPT,DA,DIC,DIE,DR,X
D MES^XPDUTL("Renaming and re-indexing security key...")
; Check whether the key has already been renamed
I $O(^DIC(19.1,"B","IBCNE IIV AUTO MATCH",0))'>0,+$O(^DIC(19.1,"B","IBCNE EIV MAINTENANCE",0)) D MES^XPDUTL("Key IBCNE IIV AUTO MATCH already renamed.") Q
;
S IBFLAG=$$RENAME^XPDKEY("IBCNE IIV AUTO MATCH","IBCNE EIV MAINTENANCE")
I 'IBFLAG D MES^XPDUTL("Key IBCNE IIV AUTO MATCH not renamed!"),MES^XPDUTL("Aborting security key updates.") Q
;
; Lock options IBCNE PAYER MAINTENANCE MENU, IBCNE PAYER EDIT, and IBCNE PAYER LINK with newly named key
D MES^XPDUTL("Assigning key to options...")
F IBOPT="MAINTENANCE MENU","EDIT","LINK" D
.S DA=$$FIND1^DIC(19,"","X","IBCNE PAYER "_IBOPT,"B")
.I 'DA D MES^XPDUTL("Option IBCNE PAYER "_IBOPT_" not found in system.") Q
.S DIE=19,DR="3///IBCNE EIV MAINTENANCE"
.L +^DIC(19,DA):0 I $T D ^DIE L -^DIC(19,DA) Q
.D MES^XPDUTL("Option IBCNE PAYER "_IBOPT_" is locked by another user.")
;
; Lock protocol IBCNSC INS CO PAYER with newly named key
D MES^XPDUTL("Assigning key to protocol...")
S DA=$$FIND1^DIC(101,"","X","IBCNSC INS CO PAYER","B") D
.I 'DA D MES^XPDUTL("Protocol IBCNSC INS CO PAYER not found in system.") Q
.S DIE=101,DR="3///IBCNE EIV MAINTENANCE"
.L +^ORD(101,DA):0 I $T D ^DIE L -^ORD(101,DA) Q
.D MES^XPDUTL("Protocol IBCNSC INS CO PAYER is locked by another user.")
;
Q
;
ADDUSR ; Add the user to the New Person file (#200)
N DIC,X,Y,DO,DD,DLAYGO,IBNAME,IBIEN,IBERR,IBARR
;
S IBNAME="AUTOUPDATE,IBEIV"
S IBIEN=$$FIND1^DIC(200,"","MX",IBNAME,"","","IBERR") I $D(IBERR) D BMES^XPDUTL("Error in ADDUSR-IBY528PO - Cannot add "_IBNAME_" to New Person file #200") Q
I +IBIEN D BMES^XPDUTL("User "_IBNAME_" already exists in the NEW PERSON file - not added") Q
;
D BMES^XPDUTL("Adding new user, "_IBNAME_", to the NEW PERSON file")
S DIC(0)="LMX"
S IBARR(200,"+1,",.01)=IBNAME,IBARR(200,"+1,",1)="MRA"
D UPDATE^DIE("E","IBARR","IBIEN","IBERR")
;
I '+$G(IBIEN(1))!($D(IBERR)) D Q
. D BMES^XPDUTL("A problem was encountered trying to add user, "_IBNAME)
. D BMES^XPDUTL("The entry must be added manually to the NEW PERSON file")
;
D BMES^XPDUTL("User, "_IBNAME_", was successfully added to the NEW PERSON file")
Q
;
; and then update historical comment record with "postmaster" (2.312, 1.18, .02) and
; date/time that historical comment copied into 2.312, 1.18 multiple
D BMES^XPDUTL("Copy of data existing at COMMENT - PATIENT POLICY field 2.312, 1.08 field "),BMES^XPDUTL("to new COMMENT - SUBSCRIBER POLICY multiple (2.312, 1.18)")
N PTIEN,IPIEN,IENS,DATETIME,IBNUM,IBO,IBCOM,IBXCOM,I
K ERROR,FDA
S (PTIEN,IPIEN)=0
S DATETIME=$$NOW^XLFDT()
; patient record can have 1 to many insurance policy records
; comments associated with the patient's specific insurance policy are at 2.312, 1.18 multiple
S PTIEN=0 F S PTIEN=$O(^DPT(PTIEN)) Q:'PTIEN S IPIEN=0 F S IPIEN=$O(^DPT(PTIEN,.312,IPIEN)) Q:'IPIEN D
. Q:$P($G(^DPT(PTIEN,.312,IPIEN,1)),U,8)']"" ; don't bother calling the FILER if there's nothing to populate from the old field
. ;
. ; -- quit if comment archived already
. S IBCOM=$P(^DPT(PTIEN,.312,IPIEN,1),U,8),IBO=0
. F I=0:0 S I=$O(^DPT(PTIEN,.312,IPIEN,13,I)) Q:I'>0!(IBO) D
. . S IBXCOM=$G(^DPT(PTIEN,.312,IPIEN,13,I,1))
. . I IBCOM=IBXCOM S IBO=1
. Q:IBO
. ;
. S IENS="+1"_","_IPIEN_","_PTIEN_","
. S FDA(2.342,IENS,.01)=DATETIME
. S FDA(2.342,IENS,.02)=.5
. S FDA(2.342,IENS,.03)=$P(^DPT(PTIEN,.312,IPIEN,1),U,8)
. D UPDATE^DIE(,"FDA",,"ERROR")
. I $D(ERROR) D
. . S IBNUM=+$G(ERROR("DIERR"))
. . D BMES^XPDUTL("File: "_$G(ERROR("DIERR",IBNUM,"PARAM","FILE")))
. . D BMES^XPDUTL("IENS: "_$G(ERROR("DIERR",IBNUM,"PARAM","IENS")))
. . D BMES^XPDUTL("Field: "_$G(ERROR("DIERR",IBNUM,"PARAM","FIELD")))
. . K ERROR
Q
;
TYPE ; add type of plan entries to #355.1
D ADTYPPLN^IBY528PA
Q
;
SRCINF ; add new source of information entry to #355.12
D ADSRCINF^IBY528PA
Q
;IBY528PO
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBY528PO 5472 printed Apr 09, 2024@21:08:40 Page 2
IBY528PO ;ALB/CJS - Post install routine for patch 528 ;5-APR-15
+1 ;;2.0;INTEGRATED BILLING;**528**;21-MAR-94;Build 163
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ; This post-install routine will rename a security key; assign
+6 ; it to three additional menu options and an action protocol;
+7 ; and remove another security key from the three menu options.
+8 ;
+9 ; The name of the IBCNE IIV AUTO MATCH key will be changed to
+10 ; IBCNE EIV MAINTENANCE.
+11 ;
+12 ; The newly named IBCNE EIV MAINTENANCE key will be used to lock
+13 ; the following menu options in place of the current IB INSURANCE
+14 ; SUPERVISOR lock:
+15 ; IBCNE PAYER MAINTENANCE MENU
+16 ; IBCNE PAYER EDIT
+17 ; IBCNE PAYER LINK
+18 ;
+19 ; It will also be used to lock the Payer action (PA) action on
+20 ; the IBCN INSURANCE CO EDIT screen.
+21 ;
+22 ; Then this routine will also add a new user.
+23 ;
START ; CALL SECTIONS
+1 DO MES^XPDUTL(" Starting post-install for IB*2.0*528")
+2 NEW IBY,Y
+3 FOR IBY="KEYS","ADDUSR","COMMENTS","TYPE","SRCINF"
Begin DoDot:1
+4 SET Y=$$NEWCP^XPDUTL(IBY,IBY_"^IBY528PO")
+5 if 'Y
DO BMES^XPDUTL("ERROR Creating "_IBY_" Checkpoint.")
End DoDot:1
+6 ; Completion message
+7 DO MES^XPDUTL(" Finished post-install for IB*2.0*528")
+8 QUIT
+9 ;
KEYS ; Rename IBCNE IIV AUTO MATCH security key to IBCNE EIV MAINTENANCE
+1 NEW IBFLAG,IBOPT,DA,DIC,DIE,DR,X
+2 DO MES^XPDUTL("Renaming and re-indexing security key...")
+3 ; Check whether the key has already been renamed
+4 IF $ORDER(^DIC(19.1,"B","IBCNE IIV AUTO MATCH",0))'>0
IF +$ORDER(^DIC(19.1,"B","IBCNE EIV MAINTENANCE",0))
DO MES^XPDUTL("Key IBCNE IIV AUTO MATCH already renamed.")
QUIT
+5 ;
+6 SET IBFLAG=$$RENAME^XPDKEY("IBCNE IIV AUTO MATCH","IBCNE EIV MAINTENANCE")
+7 IF 'IBFLAG
DO MES^XPDUTL("Key IBCNE IIV AUTO MATCH not renamed!")
DO MES^XPDUTL("Aborting security key updates.")
QUIT
+8 ;
+9 ; Lock options IBCNE PAYER MAINTENANCE MENU, IBCNE PAYER EDIT, and IBCNE PAYER LINK with newly named key
+10 DO MES^XPDUTL("Assigning key to options...")
+11 FOR IBOPT="MAINTENANCE MENU","EDIT","LINK"
Begin DoDot:1
+12 SET DA=$$FIND1^DIC(19,"","X","IBCNE PAYER "_IBOPT,"B")
+13 IF 'DA
DO MES^XPDUTL("Option IBCNE PAYER "_IBOPT_" not found in system.")
QUIT
+14 SET DIE=19
SET DR="3///IBCNE EIV MAINTENANCE"
+15 LOCK +^DIC(19,DA):0
IF $TEST
DO ^DIE
LOCK -^DIC(19,DA)
QUIT
+16 DO MES^XPDUTL("Option IBCNE PAYER "_IBOPT_" is locked by another user.")
End DoDot:1
+17 ;
+18 ; Lock protocol IBCNSC INS CO PAYER with newly named key
+19 DO MES^XPDUTL("Assigning key to protocol...")
+20 SET DA=$$FIND1^DIC(101,"","X","IBCNSC INS CO PAYER","B")
Begin DoDot:1
+21 IF 'DA
DO MES^XPDUTL("Protocol IBCNSC INS CO PAYER not found in system.")
QUIT
+22 SET DIE=101
SET DR="3///IBCNE EIV MAINTENANCE"
+23 LOCK +^ORD(101,DA):0
IF $TEST
DO ^DIE
LOCK -^ORD(101,DA)
QUIT
+24 DO MES^XPDUTL("Protocol IBCNSC INS CO PAYER is locked by another user.")
End DoDot:1
+25 ;
+26 QUIT
+27 ;
ADDUSR ; Add the user to the New Person file (#200)
+1 NEW DIC,X,Y,DO,DD,DLAYGO,IBNAME,IBIEN,IBERR,IBARR
+2 ;
+3 SET IBNAME="AUTOUPDATE,IBEIV"
+4 SET IBIEN=$$FIND1^DIC(200,"","MX",IBNAME,"","","IBERR")
IF $DATA(IBERR)
DO BMES^XPDUTL("Error in ADDUSR-IBY528PO - Cannot add "_IBNAME_" to New Person file #200")
QUIT
+5 IF +IBIEN
DO BMES^XPDUTL("User "_IBNAME_" already exists in the NEW PERSON file - not added")
QUIT
+6 ;
+7 DO BMES^XPDUTL("Adding new user, "_IBNAME_", to the NEW PERSON file")
+8 SET DIC(0)="LMX"
+9 SET IBARR(200,"+1,",.01)=IBNAME
SET IBARR(200,"+1,",1)="MRA"
+10 DO UPDATE^DIE("E","IBARR","IBIEN","IBERR")
+11 ;
+12 IF '+$GET(IBIEN(1))!($DATA(IBERR))
Begin DoDot:1
+13 DO BMES^XPDUTL("A problem was encountered trying to add user, "_IBNAME)
+14 DO BMES^XPDUTL("The entry must be added manually to the NEW PERSON file")
End DoDot:1
QUIT
+15 ;
+16 DO BMES^XPDUTL("User, "_IBNAME_", was successfully added to the NEW PERSON file")
+17 QUIT
+18 ;
+1 ; and then update historical comment record with "postmaster" (2.312, 1.18, .02) and
+2 ; date/time that historical comment copied into 2.312, 1.18 multiple
+3 DO BMES^XPDUTL("Copy of data existing at COMMENT - PATIENT POLICY field 2.312, 1.08 field ")
DO BMES^XPDUTL("to new COMMENT - SUBSCRIBER POLICY multiple (2.312, 1.18)")
+4 NEW PTIEN,IPIEN,IENS,DATETIME,IBNUM,IBO,IBCOM,IBXCOM,I
+5 KILL ERROR,FDA
+6 SET (PTIEN,IPIEN)=0
+7 SET DATETIME=$$NOW^XLFDT()
+8 ; patient record can have 1 to many insurance policy records
+9 ; comments associated with the patient's specific insurance policy are at 2.312, 1.18 multiple
+10 SET PTIEN=0
FOR
SET PTIEN=$ORDER(^DPT(PTIEN))
if 'PTIEN
QUIT
SET IPIEN=0
FOR
SET IPIEN=$ORDER(^DPT(PTIEN,.312,IPIEN))
if 'IPIEN
QUIT
Begin DoDot:1
+11 ; don't bother calling the FILER if there's nothing to populate from the old field
if $PIECE($GET(^DPT(PTIEN,.312,IPIEN,1)),U,8)']""
QUIT
+12 ;
+13 ; -- quit if comment archived already
+14 SET IBCOM=$PIECE(^DPT(PTIEN,.312,IPIEN,1),U,8)
SET IBO=0
+15 FOR I=0:0
SET I=$ORDER(^DPT(PTIEN,.312,IPIEN,13,I))
if I'>0!(IBO)
QUIT
Begin DoDot:2
+16 SET IBXCOM=$GET(^DPT(PTIEN,.312,IPIEN,13,I,1))
+17 IF IBCOM=IBXCOM
SET IBO=1
End DoDot:2
+18 if IBO
QUIT
+19 ;
+20 SET IENS="+1"_","_IPIEN_","_PTIEN_","
+21 SET FDA(2.342,IENS,.01)=DATETIME
+22 SET FDA(2.342,IENS,.02)=.5
+23 SET FDA(2.342,IENS,.03)=$PIECE(^DPT(PTIEN,.312,IPIEN,1),U,8)
+24 DO UPDATE^DIE(,"FDA",,"ERROR")
+25 IF $DATA(ERROR)
Begin DoDot:2
+26 SET IBNUM=+$GET(ERROR("DIERR"))
+27 DO BMES^XPDUTL("File: "_$GET(ERROR("DIERR",IBNUM,"PARAM","FILE")))
+28 DO BMES^XPDUTL("IENS: "_$GET(ERROR("DIERR",IBNUM,"PARAM","IENS")))
+29 DO BMES^XPDUTL("Field: "_$GET(ERROR("DIERR",IBNUM,"PARAM","FIELD")))
+30 KILL ERROR
End DoDot:2
End DoDot:1
+31 QUIT
+32 ;
TYPE ; add type of plan entries to #355.1
+1 DO ADTYPPLN^IBY528PA
+2 QUIT
+3 ;
SRCINF ; add new source of information entry to #355.12
+1 DO ADSRCINF^IBY528PA
+2 QUIT
+3 ;IBY528PO
