- 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 Dec 13, 2024@01:50:14 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