source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IB20P336.m@ 1006

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