- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCC1.m
r613 r623 1 IBCC1 ;ALB/MJB - CANCEL THIRD PARTY BILL ;10-OCT-94 2 ;;2.0;INTEGRATED BILLING;**19,95,160,159,320,347,377**;21-MAR-94;Build 23 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 RNB ; -- Add a reason not billable to claims tracking 6 N X,Y,DIC,DIE,I,J,DA,DR,IBTYP,IBTRE,IB,IBAPPT,IBDT,IBTALK,IBCODE,IBTRED,IBTSAV,FILL,IBRX,IBDATA,IBD,IBDT,IBQUIT,IBPRO,IBDD 7 N ZT,TCNT,CNT 8 Q:'$G(IBIFN) 9 S IB(0)=$G(^DGCR(399,IBIFN,0)),IBTYP=$P(IB(0),"^",5),IBQUIT=0 10 I '$D(DFN) S DFN=$P(IB(0),"^",2) 11 KILL ^TMP($J,"IBCC1") 12 ; 13 ; -- is inpt find entry in dgpm, then in ibt(356, s da=ibtre then edit 14 INPT I IBTYP<3 D 15 .S DATE=$P(IB(0),"^",3),DFN=$P(IB(0),"^",2) 16 .S DGPM=$O(^DGPM("APTT1",DFN,DATE,0)) ; double check for asih 17 .I DGPM S (IBTRE,IBTSAV)=$O(^IBT(356,"AD",DGPM,0)) 18 .I $G(IBTRE) D CTSET(IBTRE) 19 .Q:IBQUIT 20 .; 21 .; -- alternate inpt method 22 .S IBCODE=$O(^IBE(356.6,"ACODE",1,0)) 23 .S DATE=$P(IB(0),"^",3),DFN=$P(IB(0),"^",2) 24 .S IBDT=(DATE-.25) F S IBDT=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT)) Q:'IBDT!(IBDT>(DATE+.24)) D 25 ..S IBTRE=0 F S IBTRE=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT,IBTRE)) Q:IBTRE=""!(IBQUIT) D:$G(IBTSAV)'=IBTRE CTSET(IBTRE) 26 .Q 27 ; 28 OPT ; -- is opt-find entries in IBT(356, for opt dates and then edit 29 I IBTYP>2 S IBCODE=$O(^IBE(356.6,"ACODE",2,0)) D 30 .S IBAPPT=0 F S IBAPPT=$O(^DGCR(399,IBIFN,"OP",IBAPPT)) Q:'IBAPPT!(IBQUIT) D 31 ..S IBDT=(IBAPPT-.01) F S IBDT=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT)) Q:'IBDT!(IBDT>(IBAPPT+.24)) D 32 ...S IBTRE=0 F S IBTRE=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT,IBTRE)) Q:IBTRE=""!(IBQUIT) D CTSET(IBTRE) 33 .Q 34 ; 35 RX ; -- find rx's on bill 36 S IBDD=0 F S IBDD=$O(^IBA(362.4,"AIFN"_IBIFN,IBDD)) Q:'IBDD S IBD=0 F S IBD=$O(^IBA(362.4,"AIFN"_IBIFN,IBDD,IBD)) Q:'IBD!(IBQUIT) D 37 .S IBDATA=$G(^IBA(362.4,IBD,0)),IBRX=$P(IBDATA,"^",5),IBDT=$P(IBDATA,"^",3) 38 .I '$G(IBRX) S DIC=52,DIC(0)="BO",X=$P(IBDATA,"^",1) D DIC^PSODI(52,.DIC,X) S IBRX=+Y K DIC,X,Y Q:IBRX=-1 39 .S FILL="" F S FILL=$O(^IBT(356,"ARXFL",IBRX,FILL)) Q:FILL=""!(IBQUIT) D 40 ..S IBTRE=0 F S IBTRE=$O(^IBT(356,"ARXFL",IBRX,FILL,IBTRE)) Q:'IBTRE!(IBQUIT) I $P(^IBT(356,+IBTRE,0),"^",6)=IBDT D CTSET(IBTRE) 41 ; 42 PRO ; -- find prosthetics on bill 43 S IBDD=0 F S IBDD=$O(^IBA(362.5,"AIFN"_IBIFN,IBDD)) Q:'IBDD S IBD=0 F S IBD=$O(^IBA(362.5,"AIFN"_IBIFN,IBDD,IBD)) Q:'IBD!(IBQUIT) D 44 .S IBDATA=$G(^IBA(362.5,IBD,0)),IBPRO=$P(IBDATA,"^",4) 45 .Q:'$G(IBPRO) 46 .S IBTRE=0 F S IBTRE=$O(^IBT(356,"APRO",+IBPRO,IBTRE)) Q:'IBTRE!(IBQUIT) D CTSET(IBTRE) 47 ; 48 ; ----- Finished with the gathering of the CT data entries ----- 49 ; 50 ; count up the total number of CT entries recorded in the scratch global 51 S ZT="",TCNT=0 52 F S ZT=$O(^TMP($J,"IBCC1",ZT)) Q:ZT="" S IBTRE=0 F S IBTRE=$O(^TMP($J,"IBCC1",ZT,IBTRE)) Q:'IBTRE S TCNT=TCNT+1 53 ; 54 ; loop thru all of the associated CT entries and call the RNBEDIT procedure for each one 55 S ZT="",CNT=0 56 F S ZT=$O(^TMP($J,"IBCC1",ZT)) Q:ZT=""!IBQUIT D Q:IBQUIT 57 . S IBTRE=0 F S IBTRE=$O(^TMP($J,"IBCC1",ZT,IBTRE)) Q:'IBTRE!IBQUIT S CNT=CNT+1 D RNBEDIT(IBTRE,ZT,TCNT,CNT) 58 . Q 59 ; 60 ; clean-up the scratch global when completed 61 KILL ^TMP($J,"IBCC1") 62 Q 63 ; 64 CTSET(IBTRE) ; procedure to store this CT entry in the scratch global 65 Q:'$G(IBTRE) 66 S ^TMP($J,"IBCC1",$$TYPE(IBTRE),IBTRE)="" 67 CTSETX ; 68 Q 69 ; 70 RNBEDIT(IBTRE,CTTYPE,TCNT,CNT) ; CT entry display and capture RNB data and additional comment data 71 Q:IBQUIT 72 I '$D(IBTALK) D 73 . N CTZ 74 . W !!,"Since you have canceled this bill, you may enter a Reason Not Billable and" 75 . W !,"an Additional Comment into Claims Tracking." 76 . W !,"This will take the care off of the UNBILLED lists." 77 . I TCNT=1 S CTZ="Note: There is 1 associated Claims Tracking entry." 78 . E S CTZ="Note: There are "_TCNT_" associated Claims Tracking entries." 79 . W !!,CTZ 80 . Q 81 ; 82 S IBTALK=1 83 ; 84 N %,IBTRED,IBTRED1 S IBTRED=$G(^IBT(356,IBTRE,0)),IBTRED1=$G(^IBT(356,IBTRE,1)) 85 ; 86 W !!,"Claims Tracking Entry [",CNT," of ",TCNT,"]" 87 W !?7,"Entry ID#: ",+IBTRED 88 W !?12,"Type: ",$$EXPAND^IBTRE(356,.18,$P(IBTRED,U,18)) 89 ; 90 I CTTYPE=1 D ; inpatient admission or scheduled admission 91 . W !?2,"Admission Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P") 92 . Q 93 ; 94 I CTTYPE=2 D ; outpatient visit 95 . N IBOE,IBOE0 96 . W !?6,"Visit Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P") 97 . S IBOE=+$P(IBTRED,U,4),IBOE0=$$SCE^IBSDU(IBOE) 98 . W !?10,"Clinic: ",$$GET1^DIQ(44,+$P(IBOE0,U,4)_",",.01) 99 . Q 100 ; 101 I CTTYPE=3 D ; prescription refill 102 . N PSONTALK,PSOTMP,X 103 . S PSONTALK=1 104 . S X=+$P(IBTRED,U,8)_U_+$P(IBTRED,U,10) D EN^PSOCPVW 105 . ;if refill was deleted and EN^PSOCPVW doesn't return any data use IB API 106 . I '$D(PSOTMP) D PSOCPVW^IBNCPDPC(+$P(IBTRED,U,2),+$P(IBTRED,U,8),.PSOTMP) 107 . W !?3,"Prescription#: ",$G(PSOTMP(52,+$P(IBTRED,U,8),.01,"E")) 108 . I '$P(IBTRED,U,10) W !?7,"Fill Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P") 109 . I $P(IBTRED,U,10) W !?5,"Refill Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P") 110 . W !?12,"Drug: ",$G(PSOTMP(52,+$P(IBTRED,U,8),6,"E")) 111 . Q 112 ; 113 I CTTYPE=4 D ; prosthetic item 114 . N IBDA,IBRMPR 115 . S IBDA=$P(IBTRED,U,9) 116 . D PRODATA^IBTUTL1(IBDA) 117 . W !?3,"Delivery Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P") 118 . W !?12,"Item: ",$G(IBRMPR(660,+IBDA,4,"E")) 119 . W !?5,"Description: ",$G(IBRMPR(660,+IBDA,24,"E")) 120 . Q 121 ; 122 I $G(IBMCSRNB)'="",$P(IBTRED,U,19) W !," Note: A Reason Not Billable has been previously entered",!?8,"for this Claims Tracking record." 123 I $G(IBMCSCAC)'="",$P(IBTRED1,U,8)'="" W !," Note: An Additional Comment has been previously entered",!?8,"for this Claims Tracking record." 124 ; 125 S DA=IBTRE,DIE="^IBT(356,",DR=".19" 126 I $G(IBMCSRNB)'="" S DR=".19//"_$P(IBMCSRNB,U,2) ; IB*320 MCS cancel - reason not billable 127 I $G(IBMCSCAC)'="" S DR=DR_";1.08//^S X=IBMCSCAC" ; IB*377 MCS cancel - additional comment 128 I $G(IBMCSCAC)="" S DR=DR_";1.08" ; IB*377 additional comment field SRS 3.3.2.1 129 D ^DIE 130 ; 131 ; - if the RNB or additional comment changed, update the user and date/time last edited 132 I $P(IBTRED,U,19)'=$P($G(^IBT(356,IBTRE,0)),U,19)!($P(IBTRED1,U,8)'=$P($G(^IBT(356,IBTRE,1)),U,8)) D NOW^%DTC S DR="1.03///"_%_";1.04////"_DUZ D ^DIE 133 ; 134 ; $D(Y) indicates an up-arrow exit from the DIE call (??) 135 I $D(Y) S DFN=+$P(^IBT(356,IBTRE,0),"^",2) D FIND^IBOHCT(DFN,IBTRE) S IBQUIT=1 136 Q 137 ; 138 TYPE(Z) ; function to get the type of claims tracking entry 139 ; Z is the ien to file 356 140 Q +$P($G(^IBE(356.6,+$P($G(^IBT(356,+Z,0)),U,18),0)),U,3) 141 ; 1 IBCC1 ;ALB/MJB - CANCEL UB-82 THIRD PARTY BILL ;10-OCT-94 2 ;;2.0;INTEGRATED BILLING;**19,95,160,159,320,347**;21-MAR-94;Build 24 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 RNB ; -- Add a reason not billable to claims tracking 6 N X,Y,DIC,DIE,I,J,DA,DR,IBTYP,IBTRE,IB,IBAPPT,IBDT,IBTALK,IBCODE,IBTRED,IBTSAV,FILL,IBRX,IBDATA,IBD,IBDT,IBQUIT,IBPRO,IBDD 7 Q:'$G(IBIFN) 8 S IB(0)=$G(^DGCR(399,IBIFN,0)),IBTYP=$P(IB(0),"^",5),IBQUIT=0 9 I '$D(DFN) S DFN=$P(IB(0),"^",2) 10 ; 11 ; -- is inpt find entry in dgpm, then in ibt(356, s da=ibtre then edit 12 INPT I IBTYP<3 D 13 .S DATE=$P(IB(0),"^",3),DFN=$P(IB(0),"^",2) 14 .S DGPM=$O(^DGPM("APTT1",DFN,DATE,0)) ; double check for asih 15 .I DGPM S (IBTRE,IBTSAV)=$O(^IBT(356,"AD",DGPM,0)) 16 .I $G(IBTRE) D RNBEDIT 17 .Q:IBQUIT 18 .; 19 .; -- alternate inpt method 20 .S IBCODE=$O(^IBE(356.6,"ACODE",1,0)) 21 .S DATE=$P(IB(0),"^",3),DFN=$P(IB(0),"^",2) 22 .S IBDT=(DATE-.25) F S IBDT=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT)) Q:'IBDT!(IBDT>(DATE+.24)) D 23 ..S IBTRE=0 F S IBTRE=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT,IBTRE)) Q:IBTRE=""!(IBQUIT) D:$G(IBTSAV)'=IBTRE RNBEDIT 24 .Q 25 ; 26 OPT ; -- is opt-find entries in IBT(356, for opt dates and then edit 27 I IBTYP>2 S IBCODE=$O(^IBE(356.6,"ACODE",2,0)) D 28 .S IBAPPT=0 F S IBAPPT=$O(^DGCR(399,IBIFN,"OP",IBAPPT)) Q:'IBAPPT!(IBQUIT) D 29 ..S IBDT=(IBAPPT-.01) F S IBDT=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT)) Q:'IBDT!(IBDT>(IBAPPT+.24)) D 30 ...S IBTRE=0 F S IBTRE=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT,IBTRE)) Q:IBTRE=""!(IBQUIT) D RNBEDIT 31 .Q 32 ; 33 RX ; -- find rx's on bill 34 S IBDD=0 F S IBDD=$O(^IBA(362.4,"AIFN"_IBIFN,IBDD)) Q:'IBDD S IBD=0 F S IBD=$O(^IBA(362.4,"AIFN"_IBIFN,IBDD,IBD)) Q:'IBD!(IBQUIT) D 35 .S IBDATA=$G(^IBA(362.4,IBD,0)),IBRX=$P(IBDATA,"^",5),IBDT=$P(IBDATA,"^",3) 36 .I '$G(IBRX) S DIC=52,DIC(0)="BO",X=$P(IBDATA,"^",1) D DIC^PSODI(52,.DIC,X) S IBRX=+Y K DIC,X,Y Q:IBRX=-1 37 .S FILL="" F S FILL=$O(^IBT(356,"ARXFL",IBRX,FILL)) Q:FILL=""!(IBQUIT) D 38 ..S IBTRE=0 F S IBTRE=$O(^IBT(356,"ARXFL",IBRX,FILL,IBTRE)) Q:'IBTRE!(IBQUIT) I $P(^IBT(356,+IBTRE,0),"^",6)=IBDT D RNBEDIT 39 ; 40 PRO ; -- find prosthetics on bill 41 S IBDD=0 F S IBDD=$O(^IBA(362.5,"AIFN"_IBIFN,IBDD)) Q:'IBDD S IBD=0 F S IBD=$O(^IBA(362.5,"AIFN"_IBIFN,IBDD,IBD)) Q:'IBD!(IBQUIT) D 42 .S IBDATA=$G(^IBA(362.5,IBD,0)),IBPRO=$P(IBDATA,"^",4) 43 .Q:'$G(IBPRO) 44 .S IBTRE=0 F S IBTRE=$O(^IBT(356,"APRO",+IBPRO,IBTRE)) Q:'IBTRE!(IBQUIT) D RNBEDIT 45 Q 46 ; 47 RNBEDIT ; 48 Q:IBQUIT 49 W:'$D(IBTALK) !!,"Since you have canceled this bill, you may enter a Reason Not Billable",!,"into Claims Tracking. This will take the care off of the UNBILLED lists" 50 S IBTALK=1 51 ; 52 N %,IBTRED S IBTRED=$G(^IBT(356,IBTRE,0)) 53 W !!,"Claims Tracking entry: ",+IBTRED," ",$$EXPAND^IBTRE(356,.18,$P(IBTRED,"^",18))," ",$$FMTE^XLFDT($P(IBTRED,"^",6)) 54 I $G(IBMCSRNB)'="",$P(IBTRED,U,19) W !," Note: A Reason Not Billable has been previously entered",!?8,"for this Claims Tracking record." 55 S DA=IBTRE,DIE="^IBT(356,",DR=".19" 56 I $G(IBMCSRNB)'="" S DR=".19//"_$P(IBMCSRNB,U,2) ; IB*320 MCS cancel 57 D ^DIE 58 ; 59 ; - if the RNB changed, update the user and date/time last edited 60 I $P(IBTRED,"^",19)'=$P($G(^IBT(356,IBTRE,0)),"^",19) D NOW^%DTC S DR="1.03///"_%_";1.04////"_DUZ D ^DIE 61 ; 62 ; $D(Y) indicates an up-arrow exit from the DIE call (??) 63 I $D(Y) S DFN=+$P(^IBT(356,IBTRE,0),"^",2) D FIND^IBOHCT(DFN,IBTRE) S IBQUIT=1 64 Q
Note:
See TracChangeset
for help on using the changeset viewer.
