Index: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCC1.m
===================================================================
--- WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCC1.m	(revision 613)
+++ WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCC1.m	(revision 623)
@@ -1,141 +1,64 @@
-IBCC1	;ALB/MJB - CANCEL THIRD PARTY BILL ;10-OCT-94
-	;;2.0;INTEGRATED BILLING;**19,95,160,159,320,347,377**;21-MAR-94;Build 23
-	;;Per VHA Directive 2004-038, this routine should not be modified.
-	;
-RNB	; -- Add a reason not billable to claims tracking
-	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
-	N ZT,TCNT,CNT
-	Q:'$G(IBIFN)
-	S IB(0)=$G(^DGCR(399,IBIFN,0)),IBTYP=$P(IB(0),"^",5),IBQUIT=0
-	I '$D(DFN) S DFN=$P(IB(0),"^",2)
-	KILL ^TMP($J,"IBCC1")
-	;
-	; -- is inpt find entry in dgpm, then in ibt(356, s da=ibtre then edit
-INPT	I IBTYP<3 D
-	.S DATE=$P(IB(0),"^",3),DFN=$P(IB(0),"^",2)
-	.S DGPM=$O(^DGPM("APTT1",DFN,DATE,0)) ; double check for asih
-	.I DGPM S (IBTRE,IBTSAV)=$O(^IBT(356,"AD",DGPM,0))
-	.I $G(IBTRE) D CTSET(IBTRE)
-	.Q:IBQUIT
-	.;
-	.; -- alternate inpt method
-	.S IBCODE=$O(^IBE(356.6,"ACODE",1,0))
-	.S DATE=$P(IB(0),"^",3),DFN=$P(IB(0),"^",2)
-	.S IBDT=(DATE-.25) F  S IBDT=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT)) Q:'IBDT!(IBDT>(DATE+.24))  D
-	..S IBTRE=0 F  S IBTRE=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT,IBTRE)) Q:IBTRE=""!(IBQUIT)  D:$G(IBTSAV)'=IBTRE CTSET(IBTRE)
-	.Q
-	;
-OPT	; -- is opt-find entries in IBT(356, for opt dates and then edit
-	I IBTYP>2 S IBCODE=$O(^IBE(356.6,"ACODE",2,0)) D
-	.S IBAPPT=0 F  S IBAPPT=$O(^DGCR(399,IBIFN,"OP",IBAPPT)) Q:'IBAPPT!(IBQUIT)  D
-	..S IBDT=(IBAPPT-.01) F  S IBDT=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT)) Q:'IBDT!(IBDT>(IBAPPT+.24))  D
-	...S IBTRE=0 F  S IBTRE=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT,IBTRE)) Q:IBTRE=""!(IBQUIT)  D CTSET(IBTRE)
-	.Q
-	;
-RX	; -- find rx's on bill
-	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
-	.S IBDATA=$G(^IBA(362.4,IBD,0)),IBRX=$P(IBDATA,"^",5),IBDT=$P(IBDATA,"^",3)
-	.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
-	.S FILL="" F  S FILL=$O(^IBT(356,"ARXFL",IBRX,FILL)) Q:FILL=""!(IBQUIT)  D
-	..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)
-	;
-PRO	; -- find prosthetics on bill
-	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
-	.S IBDATA=$G(^IBA(362.5,IBD,0)),IBPRO=$P(IBDATA,"^",4)
-	.Q:'$G(IBPRO)
-	.S IBTRE=0 F  S IBTRE=$O(^IBT(356,"APRO",+IBPRO,IBTRE)) Q:'IBTRE!(IBQUIT)  D CTSET(IBTRE)
-	;
-	; ----- Finished with the gathering of the CT data entries -----
-	;
-	; count up the total number of CT entries recorded in the scratch global
-	S ZT="",TCNT=0
-	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
-	;
-	; loop thru all of the associated CT entries and call the RNBEDIT procedure for each one
-	S ZT="",CNT=0
-	F  S ZT=$O(^TMP($J,"IBCC1",ZT)) Q:ZT=""!IBQUIT  D  Q:IBQUIT
-	. 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)
-	. Q
-	;
-	; clean-up the scratch global when completed
-	KILL ^TMP($J,"IBCC1")
-	Q
-	;
-CTSET(IBTRE)	; procedure to store this CT entry in the scratch global
-	Q:'$G(IBTRE)
-	S ^TMP($J,"IBCC1",$$TYPE(IBTRE),IBTRE)=""
-CTSETX	;
-	Q
-	;
-RNBEDIT(IBTRE,CTTYPE,TCNT,CNT)	; CT entry display and capture RNB data and additional comment data
-	Q:IBQUIT
-	I '$D(IBTALK) D
-	. N CTZ
-	. W !!,"Since you have canceled this bill, you may enter a Reason Not Billable and"
-	. W !,"an Additional Comment into Claims Tracking."
-	. W !,"This will take the care off of the UNBILLED lists."
-	. I TCNT=1 S CTZ="Note:  There is 1 associated Claims Tracking entry."
-	. E  S CTZ="Note:  There are "_TCNT_" associated Claims Tracking entries."
-	. W !!,CTZ
-	. Q
-	;
-	S IBTALK=1
-	;
-	N %,IBTRED,IBTRED1 S IBTRED=$G(^IBT(356,IBTRE,0)),IBTRED1=$G(^IBT(356,IBTRE,1))
-	;
-	W !!,"Claims Tracking Entry [",CNT," of ",TCNT,"]"
-	W !?7,"Entry ID#: ",+IBTRED
-	W !?12,"Type: ",$$EXPAND^IBTRE(356,.18,$P(IBTRED,U,18))
-	;
-	I CTTYPE=1 D     ; inpatient admission or scheduled admission
-	. W !?2,"Admission Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P")
-	. Q
-	;
-	I CTTYPE=2 D     ; outpatient visit
-	. N IBOE,IBOE0
-	. W !?6,"Visit Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P")
-	. S IBOE=+$P(IBTRED,U,4),IBOE0=$$SCE^IBSDU(IBOE)
-	. W !?10,"Clinic: ",$$GET1^DIQ(44,+$P(IBOE0,U,4)_",",.01)
-	. Q
-	;
-	I CTTYPE=3 D     ; prescription refill
-	. N PSONTALK,PSOTMP,X
-	. S PSONTALK=1
-	. S X=+$P(IBTRED,U,8)_U_+$P(IBTRED,U,10) D EN^PSOCPVW
-	. ;if refill was deleted and EN^PSOCPVW doesn't return any data use IB API
-	. I '$D(PSOTMP) D PSOCPVW^IBNCPDPC(+$P(IBTRED,U,2),+$P(IBTRED,U,8),.PSOTMP)
-	. W !?3,"Prescription#: ",$G(PSOTMP(52,+$P(IBTRED,U,8),.01,"E"))
-	. I '$P(IBTRED,U,10) W !?7,"Fill Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P")
-	. I $P(IBTRED,U,10) W !?5,"Refill Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P")
-	. W !?12,"Drug: ",$G(PSOTMP(52,+$P(IBTRED,U,8),6,"E"))
-	. Q
-	;
-	I CTTYPE=4 D     ; prosthetic item
-	. N IBDA,IBRMPR
-	. S IBDA=$P(IBTRED,U,9)
-	. D PRODATA^IBTUTL1(IBDA)
-	. W !?3,"Delivery Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P")
-	. W !?12,"Item: ",$G(IBRMPR(660,+IBDA,4,"E"))
-	. W !?5,"Description: ",$G(IBRMPR(660,+IBDA,24,"E"))
-	. Q
-	;
-	I $G(IBMCSRNB)'="",$P(IBTRED,U,19) W !," Note:  A Reason Not Billable has been previously entered",!?8,"for this Claims Tracking record."
-	I $G(IBMCSCAC)'="",$P(IBTRED1,U,8)'="" W !," Note:  An Additional Comment has been previously entered",!?8,"for this Claims Tracking record."
-	;
-	S DA=IBTRE,DIE="^IBT(356,",DR=".19"
-	I $G(IBMCSRNB)'="" S DR=".19//"_$P(IBMCSRNB,U,2)    ; IB*320 MCS cancel - reason not billable
-	I $G(IBMCSCAC)'="" S DR=DR_";1.08//^S X=IBMCSCAC"   ; IB*377 MCS cancel - additional comment
-	I $G(IBMCSCAC)="" S DR=DR_";1.08"                   ; IB*377 additional comment field SRS 3.3.2.1
-	D ^DIE
-	;
-	; - if the RNB or additional comment changed, update the user and date/time last edited
-	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
-	;
-	; $D(Y) indicates an up-arrow exit from the DIE call (??)
-	I $D(Y) S DFN=+$P(^IBT(356,IBTRE,0),"^",2) D FIND^IBOHCT(DFN,IBTRE) S IBQUIT=1
-	Q
-	;
-TYPE(Z)	; function to get the type of claims tracking entry
-	; Z is the ien to file 356
-	Q +$P($G(^IBE(356.6,+$P($G(^IBT(356,+Z,0)),U,18),0)),U,3)
-	;
+IBCC1 ;ALB/MJB - CANCEL UB-82 THIRD PARTY BILL ;10-OCT-94
+ ;;2.0;INTEGRATED BILLING;**19,95,160,159,320,347**;21-MAR-94;Build 24
+ ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+RNB ; -- Add a reason not billable to claims tracking
+ 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
+ Q:'$G(IBIFN)
+ S IB(0)=$G(^DGCR(399,IBIFN,0)),IBTYP=$P(IB(0),"^",5),IBQUIT=0
+ I '$D(DFN) S DFN=$P(IB(0),"^",2)
+ ;
+ ; -- is inpt find entry in dgpm, then in ibt(356, s da=ibtre then edit
+INPT I IBTYP<3 D
+ .S DATE=$P(IB(0),"^",3),DFN=$P(IB(0),"^",2)
+ .S DGPM=$O(^DGPM("APTT1",DFN,DATE,0)) ; double check for asih
+ .I DGPM S (IBTRE,IBTSAV)=$O(^IBT(356,"AD",DGPM,0))
+ .I $G(IBTRE) D RNBEDIT
+ .Q:IBQUIT
+ .;
+ .; -- alternate inpt method
+ .S IBCODE=$O(^IBE(356.6,"ACODE",1,0))
+ .S DATE=$P(IB(0),"^",3),DFN=$P(IB(0),"^",2)
+ .S IBDT=(DATE-.25) F  S IBDT=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT)) Q:'IBDT!(IBDT>(DATE+.24))  D
+ ..S IBTRE=0 F  S IBTRE=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT,IBTRE)) Q:IBTRE=""!(IBQUIT)  D:$G(IBTSAV)'=IBTRE RNBEDIT
+ .Q
+ ;
+OPT ; -- is opt-find entries in IBT(356, for opt dates and then edit
+ I IBTYP>2 S IBCODE=$O(^IBE(356.6,"ACODE",2,0)) D
+ .S IBAPPT=0 F  S IBAPPT=$O(^DGCR(399,IBIFN,"OP",IBAPPT)) Q:'IBAPPT!(IBQUIT)  D
+ ..S IBDT=(IBAPPT-.01) F  S IBDT=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT)) Q:'IBDT!(IBDT>(IBAPPT+.24))  D
+ ...S IBTRE=0 F  S IBTRE=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT,IBTRE)) Q:IBTRE=""!(IBQUIT)  D RNBEDIT
+ .Q
+ ;
+RX ; -- find rx's on bill
+ 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
+ .S IBDATA=$G(^IBA(362.4,IBD,0)),IBRX=$P(IBDATA,"^",5),IBDT=$P(IBDATA,"^",3)
+ .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
+ .S FILL="" F  S FILL=$O(^IBT(356,"ARXFL",IBRX,FILL)) Q:FILL=""!(IBQUIT)  D
+ ..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
+ ;
+PRO ; -- find prosthetics on bill
+ 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
+ .S IBDATA=$G(^IBA(362.5,IBD,0)),IBPRO=$P(IBDATA,"^",4)
+ .Q:'$G(IBPRO)
+ .S IBTRE=0 F  S IBTRE=$O(^IBT(356,"APRO",+IBPRO,IBTRE)) Q:'IBTRE!(IBQUIT)  D RNBEDIT
+ Q
+ ;
+RNBEDIT ;
+ Q:IBQUIT
+ 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"
+ S IBTALK=1
+ ;
+ N %,IBTRED S IBTRED=$G(^IBT(356,IBTRE,0))
+ W !!,"Claims Tracking entry: ",+IBTRED,"  ",$$EXPAND^IBTRE(356,.18,$P(IBTRED,"^",18)),"  ",$$FMTE^XLFDT($P(IBTRED,"^",6))
+ I $G(IBMCSRNB)'="",$P(IBTRED,U,19) W !," Note:  A Reason Not Billable has been previously entered",!?8,"for this Claims Tracking record."
+ S DA=IBTRE,DIE="^IBT(356,",DR=".19"
+ I $G(IBMCSRNB)'="" S DR=".19//"_$P(IBMCSRNB,U,2)    ; IB*320 MCS cancel
+ D ^DIE
+ ;
+ ; - if the RNB changed, update the user and date/time last edited
+ I $P(IBTRED,"^",19)'=$P($G(^IBT(356,IBTRE,0)),"^",19) D NOW^%DTC S DR="1.03///"_%_";1.04////"_DUZ D ^DIE
+ ;
+ ; $D(Y) indicates an up-arrow exit from the DIE call (??)
+ I $D(Y) S DFN=+$P(^IBT(356,IBTRE,0),"^",2) D FIND^IBOHCT(DFN,IBTRE) S IBQUIT=1
+ Q
