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

IB20P276.m

Go to the documentation of this file. 
  1. IB20P276 ;DALOI/AAT - POST INIT ACTION ;24-JUN-2003
  1.  ;;2.0;INTEGRATED BILLING;**276**;21-MAR-94
  1.  ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;
  1.  ;
  1.  ;  Post Init Description: This init will resolve the pointer issues
  1.  ;  for the new entries required in 350.2 and the update need in
  1.  ;  file 399.1. This post init is associated with path *132*.
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. EN ;
  1.  D BMES^XPDUTL(">>> Adding/modifying CLAIMS TRACKING NON-BILLABLE REASONS in the file #356.8")
  1.  D NEWNBR
  1.  ;
  1.  ;Temporary:
  1.  D BMES^XPDUTL(">>> Correcting the BPS CLAIM file, field #900 'CLOSE REASON'")
  1.  D BPSFIX
  1.  D BMES^XPDUTL(">>> Correcting 'CLOSE REASON' in the temporary IB events log")
  1.  D LOGFIX
  1.  ;
  1.  D BMES^XPDUTL(">>> Enable menu option 'IBCNR EDIT HIPAA NCPDP FLAG'")
  1.  D OPT
  1.  ;
  1.  D BMES^XPDUTL(">>> Reviewing and correcting the PLAN file entries")
  1.  D ^IBCNRXI1
  1.  ;
  1.  D BMES^XPDUTL(">>> All POST-INIT Activities have been completed. <<<")
  1.  Q
  1.  ;
  1. NEWNBR ; Add/Modify IB non-billable reasons #356.8
  1.  N IBI,IBY,IBMES
  1.  F IBI=1:1 S IBY=$P($T(REASONS+IBI),";;",2,255) Q:'IBY  D
  1.  . N IBNAME,IBE02,IBE03,IBL,IBIEN
  1.  . S IBNAME=$P(IBY,U,2) Q:IBNAME=""
  1.  . S IBE02=$P(IBY,U,3)
  1.  . S IBE03=$P(IBY,U,4)
  1.  . S $E(IBL,33-$L(IBNAME))=" "
  1.  . S IBMES="  "_$J(IBI,2)_"  "_IBNAME_IBL
  1.  . S IBIEN=$O(^IBE(356.8,"B",IBNAME,0))
  1.  . S:IBIEN="" IBIEN=0
  1.  . S:$G(^IBE(356.8,IBIEN,0))="" IBIEN=0
  1.  . I IBIEN S IBMES=IBMES_" Already on file"
  1.  . I 'IBIEN D
  1.  .. N IBRT,IBIEN,IBERR,IBCNT
  1.  .. S IBCNT=0
  1.  .. S IBRT(356.8,"+1,",.01)=IBNAME
  1.  .. S IBRT(356.8,"+1,",.02)=IBE02
  1.  .. S IBRT(356.8,"+1,",.03)=IBE03
  1.  .. D UPDATE^DIE("","IBRT","IBIEN","IBERR")
  1.  .. I $D(IBERR) D  S IBCNT=IBCNT+1
  1.  ... N Y S Y="" F  S Y=$O(IBERR(Y)) Q:Y=""  D
  1.  .... S IBMES=IBMES_" *** Error: "_$G(IBERR(Y,1,"TEXT",1))
  1.  . I IBIEN D
  1.  .. S $P(^IBE(356.8,IBIEN,0),U,2)=IBE02
  1.  .. S $P(^IBE(356.8,IBIEN,0),U,3)=IBE03
  1.  . D MES^XPDUTL(IBMES)
  1.  Q
  1.  ;
  1.  ;
  1. OPT ; Enable the menu option "IBCNR EDIT HIPAA NCPDP FLAG" 
  1.  N IEN,IBRT,IBERR
  1.  S IEN=$O(^DIC(19,"B","IBCNR EDIT HIPAA NCPDP FLAG",""))
  1.  I 'IEN D BMES^XPDUTL(" *** Error: option 'IBCNR EDIT HIPAA NCPDP FLAG' not found") Q
  1.  S IBRT(19,IEN_",",2)="@"
  1.  D FILE^DIE("E","IBRT","IBERR")
  1.  I $D(IBERR) D
  1.  . N Y S Y="" F  S Y=$O(IBERR(Y)) Q:Y=""  D
  1.  .. D BMES^XPDUTL(" *** Error: "_$G(IBERR(Y,1,"TEXT",1)))
  1.  Q
  1.  ;
  1.  ;
  1.  ; *** Not implemented ***
  1. ADDUSR ; Add the user to the New Person file (#200)
  1.  Q
  1.  N DIC,X,Y,DO,DD,DLAYGO,IBNAME
  1.  S IBNAME="E-PHARMACY"
  1.  S DIC(0)="",DIC="^VA(200,",X=IBNAME D ^DIC
  1.  I Y>0 D  Q
  1.  . D BMES^XPDUTL("User "_IBNAME_" already exists in the NEW PERSON file - not added")
  1.  D BMES^XPDUTL("Adding new user, "_IBNAME_", to the NEW PERSON file")
  1.  S DLAYGO=200,DIC(0)="L",DIC="^VA(200,",DIC("DR")="1////MRA",X=IBNAME D FILE^DICN K DIC,DO,DD,DLAYGO
  1.  I Y'>0 D  Q
  1.  . D BMES^XPDUTL("A problem was encountered trying to add user, "_IBNAME)
  1.  . D BMES^XPDUTL("The entry must be added manually to the NEW PERSON file")
  1.  ;
  1.  D BMES^XPDUTL("User, "_IBNAME_", was successfully added to the NEW PERSON file")
  1.  Q
  1.  ;
  1.  ;Temporary Clean-up procedure to eliminate QTY-DAYS SUPPLY switching
  1. VERIFY(IBIFN,IBRX,IBFIL) ;check and correct
  1.  N IBX,QTY,DSUPP,IBZ,IBRXZ
  1.  S IBRXZ=$G(^PSRX(IBRX,1,IBFIL,0)) Q:IBRXZ=""
  1.  S QTY=+$P(IBRXZ,U,4) Q:'QTY  Q:QTY>999
  1.  S DSUPP=+$P(IBRXZ,U,10) Q:'DSUPP  Q:DSUPP>90
  1.  ;
  1.  S IBX=0 F  S IBX=$O(^IBA(362.4,"C",IBIFN,IBX)) Q:'IBX  D
  1.  . ;W !,IBIFN,?10," ",IBRX,?22," ",IBFIL
  1.  . S IBZ=$G(^IBA(362.4,IBX,0)) Q:IBZ=""
  1.  . I QTY=+$P(IBZ,U,7),DSUPP=+$P(IBZ,U,6) Q
  1.  . ;W " *** INCORRECT: QTY/DAYS=",+$P(IBZ,U,7),"/",+$P(IBZ,U,6),", MUST BE ",QTY,"/",DSUPP
  1.  . D SETQTY(IBX,QTY,DSUPP)
  1.  Q
  1. SETQTY(IBX,QTY,DSUPP) ;
  1.  N IBRT,IBERR
  1.  S IBRT(362.4,IBX_",",.06)=DSUPP
  1.  S IBRT(362.4,IBX_",",.07)=QTY
  1.  D FILE^DIE("","IBRT","IBERR")
  1.  ;I $D(IBERR) W ! ZW IBERR
  1.  Q
  1.  ;
  1.  ;
  1. GETRX(IBIFN) ;Get Rx from 362.4
  1.  N IBX,IBRX,IBRXN
  1.  S IBRX=0
  1.  S IBX=+$O(^IBA(362.4,"C",+IBIFN,""))
  1.  S IBRXN=$P($G(^IBA(362.4,IBX,0)),U)
  1.  I IBRXN'="" S IBRX=+$O(^PSRX("B",IBRXN,0))
  1.  Q IBRX
  1.  ;
  1. BULL ; Generate a bulletin with modified bills.
  1.  N IBGRP,XMDUZ,XMTEXT,XMSUB,XMY
  1.  ;
  1.  S XMSUB="FIXING 'CANCELLATION' IN NCPDP ZERO BILLS"
  1.  S XMDUZ="INTEGRATED BILLING PACKAGE",XMTEXT="^TMP("_$J_",""IB20P276"","
  1.  S XMY(DUZ)=""
  1.  S XMY("G.PRCA ERROR")=""
  1.  D ^XMD
  1.  Q
  1.  ;
  1.  ;
  1. SETSTA(IBIFN) ; set the status
  1.  N IBIENS,IBFDA,IBERR
  1.  S IBIENS=IBIFN_","
  1.  S IBFDA(430,IBIENS,8)="COLLECTED/CLOSED"
  1.  D FILE^DIE("E","IBFDA","IBERR")
  1.  Q '$D(IBERR)
  1.  ;
  1. BPSFIX ;CONVERT OLD BPS CODES
  1.  N I,IBZ,IBY,IBC,IBOTH,IBT,ZNODE
  1.  S ZNODE="BPSIB-CONVERT-9002313.02-904"
  1.  I $D(^XTMP(ZNODE,0)) D MES^XPDUTL("*** Already converted") Q
  1.  F I=1:1 S IBY=$P($T(REASONS+I),";;",2,255) Q:'IBY  S IBC(+IBY)=$O(^IBE(356.8,"B",$P(IBY,U,2),0))
  1.  S IBOTH=$O(^IBE(356.8,"B","OTHER",0))
  1.  S I=0 F  S I=$O(^BPSC(I)) Q:'I  S IBZ=$G(^(I,0)) D:$P(IBZ,U,7)=""
  1.  . N IBOLD,IBNEW
  1.  . S IBOLD=$P($G(^BPSC(I,900)),U,4) Q:IBOLD=""
  1.  . S IBNEW=+$G(IBC(IBOLD)) S:'IBNEW IBNEW=IBOTH
  1.  . ;W !,"I=",I,?10,"CODE=",IBOLD,",   NEW=",IBNEW
  1.  . S $P(^BPSC(I,900),U,4)=IBNEW
  1.  . S $P(^BPSC(I,0),U,7)=0  ; as a flag to avoid double conversion
  1.  S ^XTMP(ZNODE,0)=$$FMADD^XLFDT(DT,365)_U_DT_U_"BPS CONVERSION FLAG"
  1.  Q
  1.  ;
  1. LOGFIX ;CONVERT CLOSE REASON IN THE IB LOG
  1.  N I,J,IBNODE,IBZ,IBY,IBC,IBOTH,IBT,IBDROP
  1.  F I=1:1 S IBY=$P($T(REASONS+I),";;",2,255) Q:'IBY  S IBC(+IBY)=$O(^IBE(356.8,"B",$P(IBY,U,2),0))
  1.  S IBOTH=$O(^IBE(356.8,"B","OTHER",0))
  1.  ;
  1.  S (I,IBNODE)="IBNCPDP-"
  1.  F  S I=$O(^XTMP(I)) Q:I'[IBNODE  D
  1.  . S J=0 F  S J=$O(^XTMP(I,J)) Q:'J  D
  1.  .. I '$D(^XTMP(I,J,"IBD","CLOSE REASON")) Q
  1.  .. I $D(^XTMP(I,J,"IBD","DROP TO PAPER")) Q  ; Already converted
  1.  .. N IBOLD,IBNEW
  1.  .. S IBOLD=$G(^XTMP(I,J,"IBD","CLOSE REASON")) Q:IBOLD=""
  1.  .. S IBNEW=+$G(IBC(IBOLD)) S:'IBNEW IBNEW=IBOTH
  1.  .. ;W !,"I=",I,",  J=",J,",",?15,"CODE=",IBOLD,",   NEW=",IBNEW
  1.  .. S ^XTMP(I,J,"IBD","CLOSE REASON")=IBNEW
  1.  .. S ^XTMP(I,J,"IBD","DROP TO PAPER")=(IBOLD=1)  ;flag to avoid double conversion
  1.  Q
  1.  ;
  1. REASONS ;CLOSE REASON  to add/modify into file #356.8
  1.  ;;2^NOT INSURED^1^0
  1.  ;;3^SERVICE NOT COVERED^1^0
  1.  ;;4^COVERAGE CANCELED^1^0
  1.  ;;6^INVALID PRESCRIPTION ENTRY^1^0
  1.  ;;7^PRESCRIPTION DELETED^1^0
  1.  ;;8^PRESCRIPTION NOT RELEASED^1^0
  1.  ;;5^DRUG NOT BILLABLE^1^0
  1.  ;;10^90 DAY RX FILL NOT COVERED^1^1
  1.  ;;11^NOT A CONTRACTED PROVIDER^1^1
  1.  ;;12^INVALID MULTIPLES PER DAY SUPP^1^0
  1.  ;;13^REFILL TOO SOON^1^0
  1.  ;;9^INVALID NDC FROM CMOP^1^0
  1.  ;;1^OTHER^1^1
  1.  ;;