BPS10P11 ;ALB/DMB - Post-install for BPS*1.0*11 ;04/08/2011
;;1.0;E CLAIMS MGMT ENGINE;**11**;JUN 2004;Build 27
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; Reference to FILESEC^DDMOD supported by IA 2916
;
Q
;
POST ; Entry Point for post-install
D BMES^XPDUTL(" Starting post-install of BPS*1*11")
;
; Update BPS NCPDP REJECT CODES dictionary with CHAMPVA DRUG NON BILLABLE, 569, 597
D BPS93
; Update the GET CODE for BPS NCPCP FIELD DEFS
D FLDDEFS
; Remove 401 from the Transaction multiple of BPS Claims
D CLAIM
; Update PATIENT RELATIONSHIP CODE in BPS INSURER DATA records
D PRC
; Update the compiled menu protocol BPS PRTCL USRSCR HIDDEN ACTIONS
D MENU
; Change order of DUR codes in BPS REQUESTS file
D BPSREQ
; Update BPS NCPDP FIELD CODES FILE (#9002313.94)
D FLDCODE
; Update file security for the BPS NCPDP FIELD CODES (9002313.94) file
D DDSCRTY
;
D BMES^XPDUTL(" Finished post-install of BPS*1*11")
Q
;
BPS93 ;
N X,Y,BPSFIEN,DIC
D BMES^XPDUTL(" Updating BPS NCPDP REJECT CODES")
D
. I $D(^BPSF(9002313.93,"B","eC")) D Q
.. D MES^XPDUTL(" - eC already exists in the BPS NCPDP REJECT CODES dictionary.")
. S DIC=9002313.93,X="eC",DIC(0)="",DIC("DR")=".02///CHAMPVA-DRUG NON BILLABLE"
. D FILE^DICN
. S X=" - eC:CHAMPVA-DRUG NON BILLABLE was "_$S(Y=-1:"*NOT* ",1:"")_"added to BPS NCPDP REJECT CODES."
. D MES^XPDUTL(X)
D
. I $D(^BPSF(9002313.93,"B",569)) D Q
.. D MES^XPDUTL(" - 569 already exists in the BPS NCPDP REJECT CODES dictionary.")
. S DIC=9002313.93,X=569,DIC(0)="",DIC("DR")=".02///Provide Beneficiary with CMS Notice of Appeal Rights"
. D FILE^DICN
. S X=" - 569:Provide Beneficiary with CMS Notice of Appeal Rights was "_$S(Y=-1:"*NOT* ",1:"")_"added to BPS NCPDP REJECT CODES."
. D MES^XPDUTL(X)
D
. I $D(^BPSF(9002313.93,"B",597)) D Q
.. D MES^XPDUTL(" - 597 already exists in the BPS NCPDP REJECT CODES dictionary.")
. S DIC=9002313.93,X=597,DIC(0)="",DIC("DR")=".02///LTC Dispensing type does not support the packaging type"
. D FILE^DICN
. S X=" - 597:LTC Dispensing type does not support the packaging type was "_$S(Y=-1:"*NOT* ",1:"")_"added to BPS NCPDP REJECT CODES."
. D MES^XPDUTL(X)
D MES^XPDUTL(" - Done with updating BPS NCPDP REJECT CODES")
Q
;
FLDDEFS ;
N TEXT,BPX,CNT,OK,FIELD,IEN,GETCODE,SETCODE,MC,ERRMSG,FKI,FKV,D0FRMTCD,FRMTCD,PREIEN,FLAGS
D BMES^XPDUTL(" Updating BPS NCPDP FIELD DEFS")
S (CNT,PREIEN)=0
F BPX=1:1 S TEXT=$P($T(FIELDS+BPX),";;",2,99) Q:TEXT="" D
. S FIELD=$P(TEXT,";",1) ; ncpdp field#
. S IEN=+$O(^BPSF(9002313.91,"B",FIELD,0)) ; ien to file# 9002313.91
. I IEN=0 D MES^XPDUTL(" - Error: can't find entry for the NCPDP field # "_FIELD_" in the file") Q
. ;
. D MES^XPDUTL(" - Updating data for the NCPDP field# "_FIELD_"...")
. S OK=0
. ;
. S GETCODE=$P(TEXT,";",2)
. I GETCODE]"" D
.. K MC,ERRMSG S MC(1,0)=GETCODE
.. D WP^DIE(9002313.91,IEN_",",10,"","MC","ERRMSG")
.. I $D(ERRMSG) D Q
... D MES^XPDUTL(" - FileMan reported a problem with the GET CODE for field# "_FIELD)
... S (FKI,FKV)="ERRMSG"
... F S FKI=$Q(@FKI) Q:FKI'[FKV D MES^XPDUTL(" - "_FKI_" = "_$G(@FKI))
... D MES^XPDUTL(" ")
... Q
. S OK=OK+1
. ;
. S SETCODE=$P(TEXT,";",3) ; SET code
. I SETCODE]"" D
.. K MC,ERRMSG S MC(1,0)=SETCODE
.. D WP^DIE(9002313.91,IEN_",",30,"","MC","ERRMSG")
.. I $D(ERRMSG) D Q
... D MES^XPDUTL(" - FileMan reported a problem with the SET CODE for field# "_FIELD)
... S (FKI,FKV)="ERRMSG"
... F S FKI=$Q(@FKI) Q:FKI'[FKV D MES^XPDUTL(" - "_FKI_" = "_$G(@FKI))
... D MES^XPDUTL(" ")
... Q
. S OK=OK+1
. ;
. S D0FRMTCD=$P(TEXT,";",4) ; D0 FORMAT code
. I D0FRMTCD]"" D
.. K MC,ERRMSG
.. S MC(1,0)=D0FRMTCD
.. S FLAGS="" I IEN=PREIEN S FLAGS="A"
.. D WP^DIE(9002313.91,IEN_",",20,FLAGS,"MC","ERRMSG")
.. I $D(ERRMSG) D Q
... D MES^XPDUTL(" - FileMan reported a problem with the D0 FORMAT CODE for field# "_FIELD)
... S (FKI,FKV)="ERRMSG"
... F S FKI=$Q(@FKI) Q:FKI'[FKV D MES^XPDUTL(" - "_FKI_" = "_$G(@FKI))
... D MES^XPDUTL(" ")
... Q
. S OK=OK+1
. ;
. S FRMTCD=$P(TEXT,";",5) ; FORMAT code
. I FRMTCD]"" D
.. K MC,ERRMSG
.. S MC(1,0)=FRMTCD
.. D WP^DIE(9002313.91,IEN_",",40,"","MC","ERRMSG")
.. I $D(ERRMSG) D Q
... D MES^XPDUTL(" - FileMan reported a problem with the FORMAT CODE for field# "_FIELD)
... S (FKI,FKV)="ERRMSG"
... F S FKI=$Q(@FKI) Q:FKI'[FKV D MES^XPDUTL(" - "_FKI_" = "_$G(@FKI))
... D MES^XPDUTL(" ")
... Q
. S OK=OK+1
. ;
. I OK=4 S:'(PREIEN=IEN) CNT=CNT+1
. S PREIEN=IEN
D MES^XPDUTL(" - Update to BPS NCPDP FIELD DEFS is complete. "_CNT_" records updated.")
Q
;
FIELDS ; NCPDP field;GET code;SET code;D0 FORMAT code;FORMAT code
;;325;;;S BPS("X")=$TR($G(BPS("X")),"-/._","");
;;325;;;S BPS("X")=$$ANFF^BPSECFM(BPS("X"),15)
;;401;S BPS("X")=$G(BPS("NCPDP","DOS"));S $P(^BPSC(BPS(9002313.02),401),U,1)=BPS("X")
;;402;;;I $L($G(BPS("X")))>12 S BPS("X")=$E(BPS("X"),$L(BPS("X"))-11,$L(BPS("X")));
;;402;;;S BPS("X")=$$NFF^BPSECFM($G(BPS("X")),12)
;;409;S BPS("X")=$G(BPS("RX",BPS(9002313.0201),"Ingredient Cost"))
;;412;S BPS("X")=$G(BPS("RX",BPS(9002313.0201),"Dispensing Fee"))
;;436;S BPS("X")=$G(BPS("RX",BPS(9002313.0201),"Product ID Qualifier"))
;;483;;;S BPS("X")=$$DFF^BPSECFM($G(BPS("X")),7,4);S BPS("X")=$$DFF^BPSECFM($G(BPS("X")),7,4)
;;996;;S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),990),U,6)=""
;
CLAIM ;
; Delete the 401 and 420 data from BPS Claims and then remove the fields.
D BMES^XPDUTL(" Updating BPS CLAIMS")
;
; Check if the fields have already been removed
; IA 2205
I '$$VFIELD^DILFD(9002313.0201,401),'$$VFIELD^DILFD(9002313.0201,420) D MES^XPDUTL(" - Data and Fields already removed. No further action.") Q
;
; Delete the data first
N IEN,IEN2,CNT,DIK,DA
S IEN=0,CNT=0
F S IEN=$O(^BPSC(IEN)) Q:'IEN D
. S IEN2=0
. F S IEN2=$O(^BPSC(IEN,400,IEN2)) Q:'IEN2 D
.. S $P(^BPSC(IEN,400,IEN2,400),U,1)="",$P(^BPSC(IEN,400,IEN2,400),U,20)=""
.. S CNT=CNT+1
;
; Delete the fields from the data defintion
; IA 10013
S DIK="^DD(9002313.0201,",DA(1)=9002313.0201,DA=401
D ^DIK
S DIK="^DD(9002313.0201,",DA(1)=9002313.0201,DA=420
D ^DIK
;
D MES^XPDUTL(" - Done with BPS CLAIMS. "_CNT_" rows updated.")
Q
;
PRC ;Update PATIENT RELATIONSHIP CODE in BPS INSURER DATA records
N CNT,DA,DIE,DR,DTOUT,IEN
D BMES^XPDUTL(" Updating PATIENT RELATIONSHIP CODE")
S CNT=0
S IEN=0 F S IEN=$O(^BPS(9002313.78,IEN)) Q:'IEN D
. I $P($G(^BPS(9002313.78,IEN,1)),"^",5)="" Q ;Do not want to inadvertently change null value
. I +$P($G(^BPS(9002313.78,IEN,1)),"^",5)'>4 Q ;Valid value, do not change
. S CNT=CNT+1,DIE="^BPS(9002313.78,",DA=IEN,DR=1.05_"////"_4
. D ^DIE
. K DA,DR,DIE
D MES^XPDUTL(" - "_CNT_" entries updated")
D MES^XPDUTL(" - Done with updating PATIENT RELATIONSHIP CODE")
Q
;
N BPSORD,XQORM
D BMES^XPDUTL(" Removing cached hidden menu for BPS PRTCL USRSCR HIDDEN ACTIONS")
S BPSORD=$O(^ORD(101,"B","BPS PRTCL USRSCR HIDDEN ACTIONS",0))
S XQORM=BPSORD_";ORD(101,"
I $D(^XUTL("XQORM",XQORM)) K ^XUTL("XQORM",XQORM)
D MES^XPDUTL(" - Done with removing cached hidden menu for BPS PRTCL USRSCR HIDDEN ACTIONS")
Q
;
BPSREQ ;Update DUR records in BPS REQUESTS - switch first two DUR fields
N CNT,DA,DIE,DR,DTOUT,IEN,NUM,PSC,RFS,X
D BMES^XPDUTL(" Updating BPS REQUESTS file")
S CNT=0
S IEN=0 F S IEN=$O(^BPS(9002313.77,IEN)) Q:'IEN D
. S NUM=0 F S NUM=$O(^BPS(9002313.77,IEN,3,NUM)) Q:'NUM D
.. S X=$G(^BPS(9002313.77,IEN,3,NUM,0)),PSC=$P(X,"^",2),RFS=$P(X,"^",1)
.. I $D(^BPS(9002313.21,"B",RFS)),$D(^BPS(9002313.23,"B",PSC)) D ;Pieces are in wrong order
... S CNT=CNT+1
... S DIE="^BPS(9002313.77,"_IEN_",3,"
... S DA(1)=IEN,DA=NUM,DR=".01///"_PSC_";.02///"_RFS
... D ^DIE
... K DA,DR,DIE
D MES^XPDUTL(" - "_CNT_" entries updated")
D MES^XPDUTL(" - Done with updating BPS REQUESTS file")
Q
;
FLDCODE ;Update CODE multiple, DESCRIPTION field (#1) for "09" code
;
N DIE,DA,DR,KEYVAL,IEN91,IEN94,IEN1,EFLG,DTOUT
D BMES^XPDUTL(" Updating BPS NCPDP FIELD CODES")
S KEYVAL=342,IEN91="",EFLG=0
S IEN91=$O(^BPSF(9002313.91,"B",KEYVAL,IEN91))
I +IEN91,$D(^BPS(9002313.94,"B",IEN91)) D
. S IEN94="",IEN94=$O(^BPS(9002313.94,"B",IEN91,IEN94))
. I +IEN94 D Q
. . S IEN1="",IEN1=$O(^BPS(9002313.94,1,IEN94,"B","09",IEN1))
. . I +IEN1 D Q
. . . S DIE="^BPS(9002313.94,"_IEN94_",1,",DA=IEN1,DA(1)=IEN94,DR="1////COMPOUND PREPARATION COST"
. . . D ^DIE
. . D MES^XPDUTL(" - '09' not found in NCPDP FIELD CODES, CODE multiple")
. . S EFLG=1
. D MES^XPDUTL(" - No record found in NCPDP FIELD CODES")
. S EFLG=1
D:'EFLG MES^XPDUTL(" - Done with updating BPS NCPDP FIELD CODES")
Q
;
DDSCRTY ; update the Data Dictionary Security
;
D BMES^XPDUTL(" Updating file security for the BPS NCPDP FIELD CODES file")
N BPSCRTY,BPSERR,BPSFILE,V
S BPSFILE=9002313.94
S BPSCRTY("RD")="Pp"
D FILESEC^DDMOD(BPSFILE,.BPSCRTY,"BPSERR") ;IA 2916
I $D(BPSERR) D
.D MES^XPDUTL(" - error returned while updating File Security, file #"_BPSFILE)
.S V="BPSERR" F S V=$Q(@V) Q:V="" D MES^XPDUTL(" - error message: "_@V)
;
D MES^XPDUTL(" - Done with updating file security")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPS10P11 9540 printed Mar 13, 2024@23:00:19 Page 2
BPS10P11 ;ALB/DMB - Post-install for BPS*1.0*11 ;04/08/2011
+1 ;;1.0;E CLAIMS MGMT ENGINE;**11**;JUN 2004;Build 27
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; Reference to FILESEC^DDMOD supported by IA 2916
+5 ;
+6 QUIT
+7 ;
POST ; Entry Point for post-install
+1 DO BMES^XPDUTL(" Starting post-install of BPS*1*11")
+2 ;
+3 ; Update BPS NCPDP REJECT CODES dictionary with CHAMPVA DRUG NON BILLABLE, 569, 597
+4 DO BPS93
+5 ; Update the GET CODE for BPS NCPCP FIELD DEFS
+6 DO FLDDEFS
+7 ; Remove 401 from the Transaction multiple of BPS Claims
+8 DO CLAIM
+9 ; Update PATIENT RELATIONSHIP CODE in BPS INSURER DATA records
+10 DO PRC
+11 ; Update the compiled menu protocol BPS PRTCL USRSCR HIDDEN ACTIONS
+12 DO MENU
+13 ; Change order of DUR codes in BPS REQUESTS file
+14 DO BPSREQ
+15 ; Update BPS NCPDP FIELD CODES FILE (#9002313.94)
+16 DO FLDCODE
+17 ; Update file security for the BPS NCPDP FIELD CODES (9002313.94) file
+18 DO DDSCRTY
+19 ;
+20 DO BMES^XPDUTL(" Finished post-install of BPS*1*11")
+21 QUIT
+22 ;
BPS93 ;
+1 NEW X,Y,BPSFIEN,DIC
+2 DO BMES^XPDUTL(" Updating BPS NCPDP REJECT CODES")
+3 Begin DoDot:1
+4 IF $DATA(^BPSF(9002313.93,"B","eC"))
Begin DoDot:2
+5 DO MES^XPDUTL(" - eC already exists in the BPS NCPDP REJECT CODES dictionary.")
End DoDot:2
QUIT
+6 SET DIC=9002313.93
SET X="eC"
SET DIC(0)=""
SET DIC("DR")=".02///CHAMPVA-DRUG NON BILLABLE"
+7 DO FILE^DICN
+8 SET X=" - eC:CHAMPVA-DRUG NON BILLABLE was "_$SELECT(Y=-1:"*NOT* ",1:"")_"added to BPS NCPDP REJECT CODES."
+9 DO MES^XPDUTL(X)
End DoDot:1
+10 Begin DoDot:1
+11 IF $DATA(^BPSF(9002313.93,"B",569))
Begin DoDot:2
+12 DO MES^XPDUTL(" - 569 already exists in the BPS NCPDP REJECT CODES dictionary.")
End DoDot:2
QUIT
+13 SET DIC=9002313.93
SET X=569
SET DIC(0)=""
SET DIC("DR")=".02///Provide Beneficiary with CMS Notice of Appeal Rights"
+14 DO FILE^DICN
+15 SET X=" - 569:Provide Beneficiary with CMS Notice of Appeal Rights was "_$SELECT(Y=-1:"*NOT* ",1:"")_"added to BPS NCPDP REJECT CODES."
+16 DO MES^XPDUTL(X)
End DoDot:1
+17 Begin DoDot:1
+18 IF $DATA(^BPSF(9002313.93,"B",597))
Begin DoDot:2
+19 DO MES^XPDUTL(" - 597 already exists in the BPS NCPDP REJECT CODES dictionary.")
End DoDot:2
QUIT
+20 SET DIC=9002313.93
SET X=597
SET DIC(0)=""
SET DIC("DR")=".02///LTC Dispensing type does not support the packaging type"
+21 DO FILE^DICN
+22 SET X=" - 597:LTC Dispensing type does not support the packaging type was "_$SELECT(Y=-1:"*NOT* ",1:"")_"added to BPS NCPDP REJECT CODES."
+23 DO MES^XPDUTL(X)
End DoDot:1
+24 DO MES^XPDUTL(" - Done with updating BPS NCPDP REJECT CODES")
+25 QUIT
+26 ;
FLDDEFS ;
+1 NEW TEXT,BPX,CNT,OK,FIELD,IEN,GETCODE,SETCODE,MC,ERRMSG,FKI,FKV,D0FRMTCD,FRMTCD,PREIEN,FLAGS
+2 DO BMES^XPDUTL(" Updating BPS NCPDP FIELD DEFS")
+3 SET (CNT,PREIEN)=0
+4 FOR BPX=1:1
SET TEXT=$PIECE($TEXT(FIELDS+BPX),";;",2,99)
if TEXT=""
QUIT
Begin DoDot:1
+5 ; ncpdp field#
SET FIELD=$PIECE(TEXT,";",1)
+6 ; ien to file# 9002313.91
SET IEN=+$ORDER(^BPSF(9002313.91,"B",FIELD,0))
+7 IF IEN=0
DO MES^XPDUTL(" - Error: can't find entry for the NCPDP field # "_FIELD_" in the file")
QUIT
+8 ;
+9 DO MES^XPDUTL(" - Updating data for the NCPDP field# "_FIELD_"...")
+10 SET OK=0
+11 ;
+12 SET GETCODE=$PIECE(TEXT,";",2)
+13 IF GETCODE]""
Begin DoDot:2
+14 KILL MC,ERRMSG
SET MC(1,0)=GETCODE
+15 DO WP^DIE(9002313.91,IEN_",",10,"","MC","ERRMSG")
+16 IF $DATA(ERRMSG)
Begin DoDot:3
+17 DO MES^XPDUTL(" - FileMan reported a problem with the GET CODE for field# "_FIELD)
+18 SET (FKI,FKV)="ERRMSG"
+19 FOR
SET FKI=$QUERY(@FKI)
if FKI'[FKV
QUIT
DO MES^XPDUTL(" - "_FKI_" = "_$GET(@FKI))
+20 DO MES^XPDUTL(" ")
+21 QUIT
End DoDot:3
QUIT
End DoDot:2
+22 SET OK=OK+1
+23 ;
+24 ; SET code
SET SETCODE=$PIECE(TEXT,";",3)
+25 IF SETCODE]""
Begin DoDot:2
+26 KILL MC,ERRMSG
SET MC(1,0)=SETCODE
+27 DO WP^DIE(9002313.91,IEN_",",30,"","MC","ERRMSG")
+28 IF $DATA(ERRMSG)
Begin DoDot:3
+29 DO MES^XPDUTL(" - FileMan reported a problem with the SET CODE for field# "_FIELD)
+30 SET (FKI,FKV)="ERRMSG"
+31 FOR
SET FKI=$QUERY(@FKI)
if FKI'[FKV
QUIT
DO MES^XPDUTL(" - "_FKI_" = "_$GET(@FKI))
+32 DO MES^XPDUTL(" ")
+33 QUIT
End DoDot:3
QUIT
End DoDot:2
+34 SET OK=OK+1
+35 ;
+36 ; D0 FORMAT code
SET D0FRMTCD=$PIECE(TEXT,";",4)
+37 IF D0FRMTCD]""
Begin DoDot:2
+38 KILL MC,ERRMSG
+39 SET MC(1,0)=D0FRMTCD
+40 SET FLAGS=""
IF IEN=PREIEN
SET FLAGS="A"
+41 DO WP^DIE(9002313.91,IEN_",",20,FLAGS,"MC","ERRMSG")
+42 IF $DATA(ERRMSG)
Begin DoDot:3
+43 DO MES^XPDUTL(" - FileMan reported a problem with the D0 FORMAT CODE for field# "_FIELD)
+44 SET (FKI,FKV)="ERRMSG"
+45 FOR
SET FKI=$QUERY(@FKI)
if FKI'[FKV
QUIT
DO MES^XPDUTL(" - "_FKI_" = "_$GET(@FKI))
+46 DO MES^XPDUTL(" ")
+47 QUIT
End DoDot:3
QUIT
End DoDot:2
+48 SET OK=OK+1
+49 ;
+50 ; FORMAT code
SET FRMTCD=$PIECE(TEXT,";",5)
+51 IF FRMTCD]""
Begin DoDot:2
+52 KILL MC,ERRMSG
+53 SET MC(1,0)=FRMTCD
+54 DO WP^DIE(9002313.91,IEN_",",40,"","MC","ERRMSG")
+55 IF $DATA(ERRMSG)
Begin DoDot:3
+56 DO MES^XPDUTL(" - FileMan reported a problem with the FORMAT CODE for field# "_FIELD)
+57 SET (FKI,FKV)="ERRMSG"
+58 FOR
SET FKI=$QUERY(@FKI)
if FKI'[FKV
QUIT
DO MES^XPDUTL(" - "_FKI_" = "_$GET(@FKI))
+59 DO MES^XPDUTL(" ")
+60 QUIT
End DoDot:3
QUIT
End DoDot:2
+61 SET OK=OK+1
+62 ;
+63 IF OK=4
if '(PREIEN=IEN)
SET CNT=CNT+1
+64 SET PREIEN=IEN
End DoDot:1
+65 DO MES^XPDUTL(" - Update to BPS NCPDP FIELD DEFS is complete. "_CNT_" records updated.")
+66 QUIT
+67 ;
FIELDS ; NCPDP field;GET code;SET code;D0 FORMAT code;FORMAT code
+1 ;;325;;;S BPS("X")=$TR($G(BPS("X")),"-/._","");
+2 ;;325;;;S BPS("X")=$$ANFF^BPSECFM(BPS("X"),15)
+3 ;;401;S BPS("X")=$G(BPS("NCPDP","DOS"));S $P(^BPSC(BPS(9002313.02),401),U,1)=BPS("X")
+4 ;;402;;;I $L($G(BPS("X")))>12 S BPS("X")=$E(BPS("X"),$L(BPS("X"))-11,$L(BPS("X")));
+5 ;;402;;;S BPS("X")=$$NFF^BPSECFM($G(BPS("X")),12)
+6 ;;409;S BPS("X")=$G(BPS("RX",BPS(9002313.0201),"Ingredient Cost"))
+7 ;;412;S BPS("X")=$G(BPS("RX",BPS(9002313.0201),"Dispensing Fee"))
+8 ;;436;S BPS("X")=$G(BPS("RX",BPS(9002313.0201),"Product ID Qualifier"))
+9 ;;483;;;S BPS("X")=$$DFF^BPSECFM($G(BPS("X")),7,4);S BPS("X")=$$DFF^BPSECFM($G(BPS("X")),7,4)
+10 ;;996;;S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),990),U,6)=""
+11 ;
CLAIM ;
+1 ; Delete the 401 and 420 data from BPS Claims and then remove the fields.
+2 DO BMES^XPDUTL(" Updating BPS CLAIMS")
+3 ;
+4 ; Check if the fields have already been removed
+5 ; IA 2205
+6 IF '$$VFIELD^DILFD(9002313.0201,401)
IF '$$VFIELD^DILFD(9002313.0201,420)
DO MES^XPDUTL(" - Data and Fields already removed. No further action.")
QUIT
+7 ;
+8 ; Delete the data first
+9 NEW IEN,IEN2,CNT,DIK,DA
+10 SET IEN=0
SET CNT=0
+11 FOR
SET IEN=$ORDER(^BPSC(IEN))
if 'IEN
QUIT
Begin DoDot:1
+12 SET IEN2=0
+13 FOR
SET IEN2=$ORDER(^BPSC(IEN,400,IEN2))
if 'IEN2
QUIT
Begin DoDot:2
+14 SET $PIECE(^BPSC(IEN,400,IEN2,400),U,1)=""
SET $PIECE(^BPSC(IEN,400,IEN2,400),U,20)=""
+15 SET CNT=CNT+1
End DoDot:2
End DoDot:1
+16 ;
+17 ; Delete the fields from the data defintion
+18 ; IA 10013
+19 SET DIK="^DD(9002313.0201,"
SET DA(1)=9002313.0201
SET DA=401
+20 DO ^DIK
+21 SET DIK="^DD(9002313.0201,"
SET DA(1)=9002313.0201
SET DA=420
+22 DO ^DIK
+23 ;
+24 DO MES^XPDUTL(" - Done with BPS CLAIMS. "_CNT_" rows updated.")
+25 QUIT
+26 ;
PRC ;Update PATIENT RELATIONSHIP CODE in BPS INSURER DATA records
+1 NEW CNT,DA,DIE,DR,DTOUT,IEN
+2 DO BMES^XPDUTL(" Updating PATIENT RELATIONSHIP CODE")
+3 SET CNT=0
+4 SET IEN=0
FOR
SET IEN=$ORDER(^BPS(9002313.78,IEN))
if 'IEN
QUIT
Begin DoDot:1
+5 ;Do not want to inadvertently change null value
IF $PIECE($GET(^BPS(9002313.78,IEN,1)),"^",5)=""
QUIT
+6 ;Valid value, do not change
IF +$PIECE($GET(^BPS(9002313.78,IEN,1)),"^",5)'>4
QUIT
+7 SET CNT=CNT+1
SET DIE="^BPS(9002313.78,"
SET DA=IEN
SET DR=1.05_"////"_4
+8 DO ^DIE
+9 KILL DA,DR,DIE
End DoDot:1
+10 DO MES^XPDUTL(" - "_CNT_" entries updated")
+11 DO MES^XPDUTL(" - Done with updating PATIENT RELATIONSHIP CODE")
+12 QUIT
+13 ;
+1 NEW BPSORD,XQORM
+2 DO BMES^XPDUTL(" Removing cached hidden menu for BPS PRTCL USRSCR HIDDEN ACTIONS")
+3 SET BPSORD=$ORDER(^ORD(101,"B","BPS PRTCL USRSCR HIDDEN ACTIONS",0))
+4 SET XQORM=BPSORD_";ORD(101,"
+5 IF $DATA(^XUTL("XQORM",XQORM))
KILL ^XUTL("XQORM",XQORM)
+6 DO MES^XPDUTL(" - Done with removing cached hidden menu for BPS PRTCL USRSCR HIDDEN ACTIONS")
+7 QUIT
+8 ;
BPSREQ ;Update DUR records in BPS REQUESTS - switch first two DUR fields
+1 NEW CNT,DA,DIE,DR,DTOUT,IEN,NUM,PSC,RFS,X
+2 DO BMES^XPDUTL(" Updating BPS REQUESTS file")
+3 SET CNT=0
+4 SET IEN=0
FOR
SET IEN=$ORDER(^BPS(9002313.77,IEN))
if 'IEN
QUIT
Begin DoDot:1
+5 SET NUM=0
FOR
SET NUM=$ORDER(^BPS(9002313.77,IEN,3,NUM))
if 'NUM
QUIT
Begin DoDot:2
+6 SET X=$GET(^BPS(9002313.77,IEN,3,NUM,0))
SET PSC=$PIECE(X,"^",2)
SET RFS=$PIECE(X,"^",1)
+7 ;Pieces are in wrong order
IF $DATA(^BPS(9002313.21,"B",RFS))
IF $DATA(^BPS(9002313.23,"B",PSC))
Begin DoDot:3
+8 SET CNT=CNT+1
+9 SET DIE="^BPS(9002313.77,"_IEN_",3,"
+10 SET DA(1)=IEN
SET DA=NUM
SET DR=".01///"_PSC_";.02///"_RFS
+11 DO ^DIE
+12 KILL DA,DR,DIE
End DoDot:3
End DoDot:2
End DoDot:1
+13 DO MES^XPDUTL(" - "_CNT_" entries updated")
+14 DO MES^XPDUTL(" - Done with updating BPS REQUESTS file")
+15 QUIT
+16 ;
FLDCODE ;Update CODE multiple, DESCRIPTION field (#1) for "09" code
+1 ;
+2 NEW DIE,DA,DR,KEYVAL,IEN91,IEN94,IEN1,EFLG,DTOUT
+3 DO BMES^XPDUTL(" Updating BPS NCPDP FIELD CODES")
+4 SET KEYVAL=342
SET IEN91=""
SET EFLG=0
+5 SET IEN91=$ORDER(^BPSF(9002313.91,"B",KEYVAL,IEN91))
+6 IF +IEN91
IF $DATA(^BPS(9002313.94,"B",IEN91))
Begin DoDot:1
+7 SET IEN94=""
SET IEN94=$ORDER(^BPS(9002313.94,"B",IEN91,IEN94))
+8 IF +IEN94
Begin DoDot:2
+9 SET IEN1=""
SET IEN1=$ORDER(^BPS(9002313.94,1,IEN94,"B","09",IEN1))
+10 IF +IEN1
Begin DoDot:3
+11 SET DIE="^BPS(9002313.94,"_IEN94_",1,"
SET DA=IEN1
SET DA(1)=IEN94
SET DR="1////COMPOUND PREPARATION COST"
+12 DO ^DIE
End DoDot:3
QUIT
+13 DO MES^XPDUTL(" - '09' not found in NCPDP FIELD CODES, CODE multiple")
+14 SET EFLG=1
End DoDot:2
QUIT
+15 DO MES^XPDUTL(" - No record found in NCPDP FIELD CODES")
+16 SET EFLG=1
End DoDot:1
+17 if 'EFLG
DO MES^XPDUTL(" - Done with updating BPS NCPDP FIELD CODES")
+18 QUIT
+19 ;
DDSCRTY ; update the Data Dictionary Security
+1 ;
+2 DO BMES^XPDUTL(" Updating file security for the BPS NCPDP FIELD CODES file")
+3 NEW BPSCRTY,BPSERR,BPSFILE,V
+4 SET BPSFILE=9002313.94
+5 SET BPSCRTY("RD")="Pp"
+6 ;IA 2916
DO FILESEC^DDMOD(BPSFILE,.BPSCRTY,"BPSERR")
+7 IF $DATA(BPSERR)
Begin DoDot:1
+8 DO MES^XPDUTL(" - error returned while updating File Security, file #"_BPSFILE)
+9 SET V="BPSERR"
FOR
SET V=$QUERY(@V)
if V=""
QUIT
DO MES^XPDUTL(" - error message: "_@V)
End DoDot:1
+10 ;
+11 DO MES^XPDUTL(" - Done with updating file security")
+12 QUIT