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

IB20P336.m

Go to the documentation of this file. 
  1. IB20P336 ;OAK/ELZ - IB*2*336 POST INIT TO REPORT CLAIMS TRACKING PROBLEMS ;15-DEC-2005
  1.  ;;2.0;INTEGRATED BILLING;**336**;21-MAR-94
  1.  ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;
  1.  ; With the release of CIDC (IB*2*260), PSO added a new node for storage of SC/EI determinations.  However it turns
  1.  ; out this new node is not always there.  If the node is there the data contained in that node is correct for SC/EI
  1.  ; determination.  But if the node was not there IB needed to revert back to its original process for marking CT
  1.  ; entries.  That reversion was not included in IB*2*260, but is included in this IB*2*336 patch.  This post init
  1.  ; routine will look through CT entries for Pharmacy that were created after IB*2*260 was installed and evaluate
  1.  ; those CT entries.  Since some sites spend time manually reviewing these entries the entries cannot be auto-
  1.  ; matically marked and bills cannot be automatically cancelled.  So this post init routine will provide an e-mail
  1.  ; report of CT entries that should be reviewed by the site.  Also as a note the PSO IBQ node is not a reliable
  1.  ; node to look at for patients >49% SC, in fact should not ever be populated for these patients.  So if anyone
  1.  ; does a comparison they are likely to find invalid data.  PSO stopped populating IBQ for >49% SC with the
  1.  ; release of PSO*7*219.
  1.  ; 
  1.  ; 
  1. POST ; post init entry point
  1.  ;
  1.  N IBIDT,IBX,IBSTOP,IBDATA,IBDPT,IBL,IBPNM,IBZ,XMDUZ,XMSUB,XMY,XMZ
  1.  ;
  1.  D BMES^XPDUTL("Starting Post Install to evaluate CT entries...")
  1.  ;
  1.  K ^TMP("IB20P336",$J)
  1.  ;
  1.  ; dbia #2197
  1.  S IBIDT=$P($G(^XPD(9.7,+$O(^XPD(9.7,"B","IB*2.0*260",0)),1)),"^")
  1.  I 'IBIDT D BMES^XPDUTL("Cannot find first install of IB*2*260!!!  LOG A REMEDY TICKET") Q
  1.  ;
  1.  ; start at end of CT file and work backwards to beginning
  1.  S IBSTOP=0,IBX=":" F  S IBX=$O(^IBT(356,IBX),-1) Q:'IBX!(IBSTOP)  D
  1.  . S IBZ=$G(^IBT(356,IBX,0))
  1.  . Q:'$P(IBZ,"^",8)
  1.  . ;
  1.  . ; can i end?
  1.  . S IBDT=+$G(^IBT(356,IBX,1)) I IBDT,IBDT<IBIDT S IBSTOP=1 Q
  1.  . ;
  1.  . ; entry has a RNB no need to check out
  1.  . Q:$P(IBZ,"^",19)
  1.  . ;
  1.  . ; PSO has an ICD node so it was done right
  1.  . Q:$D(^PSRX($P(IBZ,"^",8),"ICD"))
  1.  . ;
  1.  . ;determine RNB would have been had CIDC not been installed, if none quit
  1.  . S IBRMARK=$$RNB($P(IBZ,"^",2),$P(IBZ,"^",6),$P(IBZ,"^",8),$G(^PSRX($P(IBZ,"^",8),0)))
  1.  . I IBRMARK="" Q
  1.  . ;
  1.  . S IBDPT=$G(^DPT(+$P(IBZ,"^",2),0)) Q:'$L(IBDPT)
  1.  . S IBDATA=$$TXT($P(IBDPT,"^"),15)_$$TXT($E($P(IBDPT,"^",9),6,9),4)
  1.  . S IBDATA=IBDATA_$$TXT($$FMTE^XLFDT($P(IBZ,"^",6),"2DZ"),8)_$$TXT($P($G(^PSRX($P(IBZ,"^",8),0)),"^"),10)
  1.  . S IBDATA=IBDATA_$$TXT($P($G(^DGCR(399,+$P(IBZ,"^",11),0)),"^"),10)_$$TXT(IBRMARK,14)
  1.  . ;
  1.  . ; get AR status
  1.  . S:$P(IBZ,"^",11) IBDATA=IBDATA_$E($P($$STA^PRCAFN(+$P(IBZ,"^",11)),"^",2),1,4)
  1.  . ; 
  1.  . S ^TMP("IB20P336",$J,$P(IBDPT,"^"),IBX)=IBDATA
  1.  ;
  1.  D BMES^XPDUTL("Sending report message...")
  1.  ;
  1.  ; get message and send
  1. RETRY ;
  1.  S XMSUB="CLAIMS TRACKING PHARMACY IB*2*336"
  1.  S XMDUZ="INTEGRATED BILLING PACKAGE"
  1.  D XMZ^XMA2
  1.  I XMZ<1 G RETRY
  1.  ;
  1.  ;set priority on message
  1.  S DIE=3.9,DA=XMZ,DR="1.7////P" D ^DIE
  1.  ;
  1.  S ^XMB(3.9,XMZ,2,1,0)="With the install of the CIDC software (IB*2*260) some pharmacy related"
  1.  S ^XMB(3.9,XMZ,2,2,0)="Claims Tracking (CT) entries may not have been assigned a Reason Not"
  1.  S ^XMB(3.9,XMZ,2,3,0)="Billable (RNB).  Below is a list of CT entries that do not have a RNB"
  1.  S ^XMB(3.9,XMZ,2,4,0)="with a RNB that should have been originally assigned to them.  Please"
  1.  S ^XMB(3.9,XMZ,2,5,0)="review the list below and assign a RNB if appropriate."
  1.  S ^XMB(3.9,XMZ,2,6,0)=" "
  1.  S ^XMB(3.9,XMZ,2,7,0)="Name             SSN   Date      Rx#         Bill#       RNB             AR"
  1.  S ^XMB(3.9,XMZ,2,8,0)="---------------  ----  --------  ----------  ----------  --------------  ----"
  1.  S IBL=8
  1.  S IBPNM="" F  S IBPNM=$O(^TMP("IB20P336",$J,IBPNM)) Q:IBPNM=""  S IBX=0 F  S IBX=$O(^TMP("IB20P336",$J,IBPNM,IBX)) Q:'IBX  D
  1.  . S IBL=IBL+1
  1.  . S ^XMB(3.9,XMZ,2,IBL,0)=^TMP("IB20P336",$J,IBPNM,IBX)
  1.  I '$D(^TMP("IB20P336",$J)) S ^XMB(3.9,XMZ,2,IBL+1,0)="    <None Found>"
  1.  S ^XMB(3.9,XMZ,2,0)="^3.92^"_IBL_"^"_IBL_"^"_DT
  1.  ;
  1.  S XMDUZ="INTEGRATED BILLING PACKAGE"
  1.  S XMY(DUZ)="" ; Individual as a recipient
  1.  F IBX="IB SUPERVISOR","IB CLAIMS SUPERVISOR" S IBZ=0 F  S IBZ=$O(^XUSEC(IBX,IBZ)) Q:'IBZ  S XMY(IBZ)=""
  1.  ;
  1.  D ENT1^XMD
  1.  ;
  1.  D BMES^XPDUTL("Message number "_XMZ_" sent...")
  1.  ;
  1.  K ^TMP("IB20P336",$J)
  1.  ;
  1.  D BMES^XPDUTL("Post Install Complete...")
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. RNB(DFN,IBDT,IBRXN,IBRXDATA) ; determines what the RNB would have been had the new ICD node not been checked
  1.  ;
  1.  N VAEL,IBRMARK,VA,IBPOWUNV,IBAUTRET
  1.  ;
  1.  D ELIG^VADPT
  1.  ;if the patient is covered by insurance for pharmacy ($G(IBRMARK)="")
  1.  ;AND if no copay in #350
  1.  ;then we need to determine the non billable reason and set IBRMARK
  1.  ;
  1.  ;IF VAEL(3) -- if this is a veteran with SC(service connection) status
  1.  I VAEL(3),'$G(^PSRX(IBRXN,"IB")) D
  1.  . I $P(VAEL(3),"^",2)>49 S IBRMARK="NEEDS SC DETERMINATION"
  1.  . ;in case of POW and Unempl. vet we cannot decide if the 3rd party should be exempt
  1.  . S IBAUTRET=$$AUTOINFO^DGMTCOU1(DFN),IBPOWUNV=$S($P(IBAUTRET,U,8):1,$P(IBAUTRET,U,9):1,1:0)
  1.  . I $P(VAEL(3),"^",2)<50 S IBRMARK=$S(IBPOWUNV:"NEEDS SC DETERMINATION",1:"SC TREATMENT")
  1.  . I $$RXST^IBARXEU(DFN,$P(IBRXDATA,U,13))>0 S IBRMARK="NEEDS SC DETERMINATION"
  1.  ;
  1.  ;IF +VAEL(3)=0 if the veteran doesn't have SC status, but
  1.  ;the veteran still may have CV status active
  1.  I $G(IBRMARK)="",+VAEL(3)=0,'$G(^PSRX(IBRXN,"IB")) D
  1.  . I $$CVEDT^IBACV(DFN,IBDT) S IBRMARK="NEEDS SC DETERMINATION" ;SC-because IB staff usually is using this reason to search for cases that need to be reviewed. COMBAT VETERAN reason will be used after review if this was the case
  1.  ;
  1.  ;
  1.  Q $G(IBRMARK)
  1.  ;
  1.  ;
  1. TXT(X,Y) ; make text Y characters long adding 2 spaces
  1.  Q $$LJ^XLFSTR($E(X,1,Y),Y+2)
  1.  ;