Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BPS10P11

BPS10P11.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ; Reference to FILESEC^DDMOD supported by IA 2916
  1. ;
  1. Q
  1. ;
  1. POST ; Entry Point for post-install
  1. D BMES^XPDUTL(" Starting post-install of BPS*1*11")
  1. ;
  1. ; Update BPS NCPDP REJECT CODES dictionary with CHAMPVA DRUG NON BILLABLE, 569, 597
  1. D BPS93
  1. ; Update the GET CODE for BPS NCPCP FIELD DEFS
  1. D FLDDEFS
  1. ; Remove 401 from the Transaction multiple of BPS Claims
  1. D CLAIM
  1. ; Update PATIENT RELATIONSHIP CODE in BPS INSURER DATA records
  1. D PRC
  1. ; Update the compiled menu protocol BPS PRTCL USRSCR HIDDEN ACTIONS
  1. D MENU
  1. ; Change order of DUR codes in BPS REQUESTS file
  1. D BPSREQ
  1. ; Update BPS NCPDP FIELD CODES FILE (#9002313.94)
  1. D FLDCODE
  1. ; Update file security for the BPS NCPDP FIELD CODES (9002313.94) file
  1. D DDSCRTY
  1. ;
  1. D BMES^XPDUTL(" Finished post-install of BPS*1*11")
  1. Q
  1. ;
  1. BPS93 ;
  1. N X,Y,BPSFIEN,DIC
  1. D BMES^XPDUTL(" Updating BPS NCPDP REJECT CODES")
  1. D
  1. . I $D(^BPSF(9002313.93,"B","eC")) D Q
  1. .. D MES^XPDUTL(" - eC already exists in the BPS NCPDP REJECT CODES dictionary.")
  1. . S DIC=9002313.93,X="eC",DIC(0)="",DIC("DR")=".02///CHAMPVA-DRUG NON BILLABLE"
  1. . D FILE^DICN
  1. . S X=" - eC:CHAMPVA-DRUG NON BILLABLE was "_$S(Y=-1:"*NOT* ",1:"")_"added to BPS NCPDP REJECT CODES."
  1. . D MES^XPDUTL(X)
  1. D
  1. . I $D(^BPSF(9002313.93,"B",569)) D Q
  1. .. D MES^XPDUTL(" - 569 already exists in the BPS NCPDP REJECT CODES dictionary.")
  1. . S DIC=9002313.93,X=569,DIC(0)="",DIC("DR")=".02///Provide Beneficiary with CMS Notice of Appeal Rights"
  1. . D FILE^DICN
  1. . S X=" - 569:Provide Beneficiary with CMS Notice of Appeal Rights was "_$S(Y=-1:"*NOT* ",1:"")_"added to BPS NCPDP REJECT CODES."
  1. . D MES^XPDUTL(X)
  1. D
  1. . I $D(^BPSF(9002313.93,"B",597)) D Q
  1. .. D MES^XPDUTL(" - 597 already exists in the BPS NCPDP REJECT CODES dictionary.")
  1. . S DIC=9002313.93,X=597,DIC(0)="",DIC("DR")=".02///LTC Dispensing type does not support the packaging type"
  1. . D FILE^DICN
  1. . S X=" - 597:LTC Dispensing type does not support the packaging type was "_$S(Y=-1:"*NOT* ",1:"")_"added to BPS NCPDP REJECT CODES."
  1. . D MES^XPDUTL(X)
  1. D MES^XPDUTL(" - Done with updating BPS NCPDP REJECT CODES")
  1. Q
  1. ;
  1. FLDDEFS ;
  1. N TEXT,BPX,CNT,OK,FIELD,IEN,GETCODE,SETCODE,MC,ERRMSG,FKI,FKV,D0FRMTCD,FRMTCD,PREIEN,FLAGS
  1. D BMES^XPDUTL(" Updating BPS NCPDP FIELD DEFS")
  1. S (CNT,PREIEN)=0
  1. F BPX=1:1 S TEXT=$P($T(FIELDS+BPX),";;",2,99) Q:TEXT="" D
  1. . S FIELD=$P(TEXT,";",1) ; ncpdp field#
  1. . S IEN=+$O(^BPSF(9002313.91,"B",FIELD,0)) ; ien to file# 9002313.91
  1. . I IEN=0 D MES^XPDUTL(" - Error: can't find entry for the NCPDP field # "_FIELD_" in the file") Q
  1. . ;
  1. . D MES^XPDUTL(" - Updating data for the NCPDP field# "_FIELD_"...")
  1. . S OK=0
  1. . ;
  1. . S GETCODE=$P(TEXT,";",2)
  1. . I GETCODE]"" D
  1. .. K MC,ERRMSG S MC(1,0)=GETCODE
  1. .. D WP^DIE(9002313.91,IEN_",",10,"","MC","ERRMSG")
  1. .. I $D(ERRMSG) D Q
  1. ... D MES^XPDUTL(" - FileMan reported a problem with the GET CODE for field# "_FIELD)
  1. ... S (FKI,FKV)="ERRMSG"
  1. ... F S FKI=$Q(@FKI) Q:FKI'[FKV D MES^XPDUTL(" - "_FKI_" = "_$G(@FKI))
  1. ... D MES^XPDUTL(" ")
  1. ... Q
  1. . S OK=OK+1
  1. . ;
  1. . S SETCODE=$P(TEXT,";",3) ; SET code
  1. . I SETCODE]"" D
  1. .. K MC,ERRMSG S MC(1,0)=SETCODE
  1. .. D WP^DIE(9002313.91,IEN_",",30,"","MC","ERRMSG")
  1. .. I $D(ERRMSG) D Q
  1. ... D MES^XPDUTL(" - FileMan reported a problem with the SET CODE for field# "_FIELD)
  1. ... S (FKI,FKV)="ERRMSG"
  1. ... F S FKI=$Q(@FKI) Q:FKI'[FKV D MES^XPDUTL(" - "_FKI_" = "_$G(@FKI))
  1. ... D MES^XPDUTL(" ")
  1. ... Q
  1. . S OK=OK+1
  1. . ;
  1. . S D0FRMTCD=$P(TEXT,";",4) ; D0 FORMAT code
  1. . I D0FRMTCD]"" D
  1. .. K MC,ERRMSG
  1. .. S MC(1,0)=D0FRMTCD
  1. .. S FLAGS="" I IEN=PREIEN S FLAGS="A"
  1. .. D WP^DIE(9002313.91,IEN_",",20,FLAGS,"MC","ERRMSG")
  1. .. I $D(ERRMSG) D Q
  1. ... D MES^XPDUTL(" - FileMan reported a problem with the D0 FORMAT CODE for field# "_FIELD)
  1. ... S (FKI,FKV)="ERRMSG"
  1. ... F S FKI=$Q(@FKI) Q:FKI'[FKV D MES^XPDUTL(" - "_FKI_" = "_$G(@FKI))
  1. ... D MES^XPDUTL(" ")
  1. ... Q
  1. . S OK=OK+1
  1. . ;
  1. . S FRMTCD=$P(TEXT,";",5) ; FORMAT code
  1. . I FRMTCD]"" D
  1. .. K MC,ERRMSG
  1. .. S MC(1,0)=FRMTCD
  1. .. D WP^DIE(9002313.91,IEN_",",40,"","MC","ERRMSG")
  1. .. I $D(ERRMSG) D Q
  1. ... D MES^XPDUTL(" - FileMan reported a problem with the FORMAT CODE for field# "_FIELD)
  1. ... S (FKI,FKV)="ERRMSG"
  1. ... F S FKI=$Q(@FKI) Q:FKI'[FKV D MES^XPDUTL(" - "_FKI_" = "_$G(@FKI))
  1. ... D MES^XPDUTL(" ")
  1. ... Q
  1. . S OK=OK+1
  1. . ;
  1. . I OK=4 S:'(PREIEN=IEN) CNT=CNT+1
  1. . S PREIEN=IEN
  1. D MES^XPDUTL(" - Update to BPS NCPDP FIELD DEFS is complete. "_CNT_" records updated.")
  1. Q
  1. ;
  1. FIELDS ; NCPDP field;GET code;SET code;D0 FORMAT code;FORMAT code
  1. ;;325;;;S BPS("X")=$TR($G(BPS("X")),"-/._","");
  1. ;;325;;;S BPS("X")=$$ANFF^BPSECFM(BPS("X"),15)
  1. ;;401;S BPS("X")=$G(BPS("NCPDP","DOS"));S $P(^BPSC(BPS(9002313.02),401),U,1)=BPS("X")
  1. ;;402;;;I $L($G(BPS("X")))>12 S BPS("X")=$E(BPS("X"),$L(BPS("X"))-11,$L(BPS("X")));
  1. ;;402;;;S BPS("X")=$$NFF^BPSECFM($G(BPS("X")),12)
  1. ;;409;S BPS("X")=$G(BPS("RX",BPS(9002313.0201),"Ingredient Cost"))
  1. ;;412;S BPS("X")=$G(BPS("RX",BPS(9002313.0201),"Dispensing Fee"))
  1. ;;436;S BPS("X")=$G(BPS("RX",BPS(9002313.0201),"Product ID Qualifier"))
  1. ;;483;;;S BPS("X")=$$DFF^BPSECFM($G(BPS("X")),7,4);S BPS("X")=$$DFF^BPSECFM($G(BPS("X")),7,4)
  1. ;;996;;S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),990),U,6)=""
  1. ;
  1. CLAIM ;
  1. ; Delete the 401 and 420 data from BPS Claims and then remove the fields.
  1. D BMES^XPDUTL(" Updating BPS CLAIMS")
  1. ;
  1. ; Check if the fields have already been removed
  1. ; IA 2205
  1. I '$$VFIELD^DILFD(9002313.0201,401),'$$VFIELD^DILFD(9002313.0201,420) D MES^XPDUTL(" - Data and Fields already removed. No further action.") Q
  1. ;
  1. ; Delete the data first
  1. N IEN,IEN2,CNT,DIK,DA
  1. S IEN=0,CNT=0
  1. F S IEN=$O(^BPSC(IEN)) Q:'IEN D
  1. . S IEN2=0
  1. . F S IEN2=$O(^BPSC(IEN,400,IEN2)) Q:'IEN2 D
  1. .. S $P(^BPSC(IEN,400,IEN2,400),U,1)="",$P(^BPSC(IEN,400,IEN2,400),U,20)=""
  1. .. S CNT=CNT+1
  1. ;
  1. ; Delete the fields from the data defintion
  1. ; IA 10013
  1. S DIK="^DD(9002313.0201,",DA(1)=9002313.0201,DA=401
  1. D ^DIK
  1. S DIK="^DD(9002313.0201,",DA(1)=9002313.0201,DA=420
  1. D ^DIK
  1. ;
  1. D MES^XPDUTL(" - Done with BPS CLAIMS. "_CNT_" rows updated.")
  1. Q
  1. ;
  1. PRC ;Update PATIENT RELATIONSHIP CODE in BPS INSURER DATA records
  1. N CNT,DA,DIE,DR,DTOUT,IEN
  1. D BMES^XPDUTL(" Updating PATIENT RELATIONSHIP CODE")
  1. S CNT=0
  1. S IEN=0 F S IEN=$O(^BPS(9002313.78,IEN)) Q:'IEN D
  1. . I $P($G(^BPS(9002313.78,IEN,1)),"^",5)="" Q ;Do not want to inadvertently change null value
  1. . I +$P($G(^BPS(9002313.78,IEN,1)),"^",5)'>4 Q ;Valid value, do not change
  1. . S CNT=CNT+1,DIE="^BPS(9002313.78,",DA=IEN,DR=1.05_"////"_4
  1. . D ^DIE
  1. . K DA,DR,DIE
  1. D MES^XPDUTL(" - "_CNT_" entries updated")
  1. D MES^XPDUTL(" - Done with updating PATIENT RELATIONSHIP CODE")
  1. Q
  1. ;
  1. N BPSORD,XQORM
  1. D BMES^XPDUTL(" Removing cached hidden menu for BPS PRTCL USRSCR HIDDEN ACTIONS")
  1. S BPSORD=$O(^ORD(101,"B","BPS PRTCL USRSCR HIDDEN ACTIONS",0))
  1. S XQORM=BPSORD_";ORD(101,"
  1. I $D(^XUTL("XQORM",XQORM)) K ^XUTL("XQORM",XQORM)
  1. D MES^XPDUTL(" - Done with removing cached hidden menu for BPS PRTCL USRSCR HIDDEN ACTIONS")
  1. Q
  1. ;
  1. BPSREQ ;Update DUR records in BPS REQUESTS - switch first two DUR fields
  1. N CNT,DA,DIE,DR,DTOUT,IEN,NUM,PSC,RFS,X
  1. D BMES^XPDUTL(" Updating BPS REQUESTS file")
  1. S CNT=0
  1. S IEN=0 F S IEN=$O(^BPS(9002313.77,IEN)) Q:'IEN D
  1. . S NUM=0 F S NUM=$O(^BPS(9002313.77,IEN,3,NUM)) Q:'NUM D
  1. .. S X=$G(^BPS(9002313.77,IEN,3,NUM,0)),PSC=$P(X,"^",2),RFS=$P(X,"^",1)
  1. .. I $D(^BPS(9002313.21,"B",RFS)),$D(^BPS(9002313.23,"B",PSC)) D ;Pieces are in wrong order
  1. ... S CNT=CNT+1
  1. ... S DIE="^BPS(9002313.77,"_IEN_",3,"
  1. ... S DA(1)=IEN,DA=NUM,DR=".01///"_PSC_";.02///"_RFS
  1. ... D ^DIE
  1. ... K DA,DR,DIE
  1. D MES^XPDUTL(" - "_CNT_" entries updated")
  1. D MES^XPDUTL(" - Done with updating BPS REQUESTS file")
  1. Q
  1. ;
  1. FLDCODE ;Update CODE multiple, DESCRIPTION field (#1) for "09" code
  1. ;
  1. N DIE,DA,DR,KEYVAL,IEN91,IEN94,IEN1,EFLG,DTOUT
  1. D BMES^XPDUTL(" Updating BPS NCPDP FIELD CODES")
  1. S KEYVAL=342,IEN91="",EFLG=0
  1. S IEN91=$O(^BPSF(9002313.91,"B",KEYVAL,IEN91))
  1. I +IEN91,$D(^BPS(9002313.94,"B",IEN91)) D
  1. . S IEN94="",IEN94=$O(^BPS(9002313.94,"B",IEN91,IEN94))
  1. . I +IEN94 D Q
  1. . . S IEN1="",IEN1=$O(^BPS(9002313.94,1,IEN94,"B","09",IEN1))
  1. . . I +IEN1 D Q
  1. . . . S DIE="^BPS(9002313.94,"_IEN94_",1,",DA=IEN1,DA(1)=IEN94,DR="1////COMPOUND PREPARATION COST"
  1. . . . D ^DIE
  1. . . D MES^XPDUTL(" - '09' not found in NCPDP FIELD CODES, CODE multiple")
  1. . . S EFLG=1
  1. . D MES^XPDUTL(" - No record found in NCPDP FIELD CODES")
  1. . S EFLG=1
  1. D:'EFLG MES^XPDUTL(" - Done with updating BPS NCPDP FIELD CODES")
  1. Q
  1. ;
  1. DDSCRTY ; update the Data Dictionary Security
  1. ;
  1. D BMES^XPDUTL(" Updating file security for the BPS NCPDP FIELD CODES file")
  1. N BPSCRTY,BPSERR,BPSFILE,V
  1. S BPSFILE=9002313.94
  1. S BPSCRTY("RD")="Pp"
  1. D FILESEC^DDMOD(BPSFILE,.BPSCRTY,"BPSERR") ;IA 2916
  1. I $D(BPSERR) D
  1. .D MES^XPDUTL(" - error returned while updating File Security, file #"_BPSFILE)
  1. .S V="BPSERR" F S V=$Q(@V) Q:V="" D MES^XPDUTL(" - error message: "_@V)
  1. ;
  1. D MES^XPDUTL(" - Done with updating file security")
  1. Q