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