IBCONS2 ;ALB/CPM - NSC W/INSURANCE OUTPUT (CON'T) ; 31-JAN-92
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;
;MAP TO DGCRONS2
;
LOOP1 ; Compilation for both Inpatient Admisssion and Discharge reports.
N DA,IBADM
D DIV
F I=(IBBEG-.0001):0 S I=$O(^DGPM(IBSUB,I)) Q:'I!(I>(IBEND+.99)) D
. S DFN=0 F S DFN=$O(^DGPM(IBSUB,I,DFN)) Q:'DFN S DA=+$O(^(DFN,0)) D D:PTF PTF I '$G(IBSC),$G(IBDV) D PROC K IBADMVT
.. S:IBINPT=2 DA=+$P($G(^DGPM(DA,0)),"^",14),IBADM=+$G(^DGPM(DA,0))
.. S PTF=$P($G(^DGPM(DA,0)),"^",16)
.. S IBADMVT=DA
.. S IBDV=+$P($G(^DIC(42,+$P($G(^DGPM(DA,0)),"^",6),0)),"^",11)
Q
;
;
LOOP2 ; Compilation for the Outpatient report.
D DIV
DIS F I=IBBEG-.0001:0 S I=$O(^DPT("ADIS",I)) Q:'I!(I>(IBEND+.99)) D
. F DFN=0:0 S DFN=$O(^DPT("ADIS",I,DFN)) Q:'DFN S J=$O(^(DFN,0)) D
.. S IBOE="" I $D(^DPT(DFN,"DIS",J,0)) S IBOE=$P($G(^DPT(DFN,"DIS",J,0)),"^",18)
.. I $D(^DPT(DFN,"DIS",J,0)),$P(^(0),U,2)<2 S IBSTOP="Registration: "_$P($G(^DIC(37,+$P(^(0),U,7),0)),"^"),IBDV=$P(^DPT(DFN,"DIS",J,0),"^",4) D PROC
;
ADD F I=IBBEG-.0001:0 S I=$O(^SDV(I)) Q:'I!(I>(IBEND+.99)) S X=$G(^(I,0)) D
. K IBOE
. S DFN=$P(X,"^",2),IBDV=$P(X,"^",3) Q:'$D(^DPT(+DFN,0))
. F N=0:0 S N=$O(^SDV(I,"CS",N)) Q:'N I $$RPT^IBEFUNC(+$P($G(^(N,0)),"^",5),I) D D PROC Q
..S IBOE=$G(IBOE)_$P($G(^SDV(I,"CS",N,0)),"^",8)_"^"
..N X S X=0
..S IBSTOP="Add/Edit Stop Code^"
..F S X=$O(^SDV(I,"CS","B",X)) Q:'X S IBSTOP=IBSTOP_$P($G(^DIC(40.7,+X,0)),"^",2)_"^"
;
CLIN F IBDC=0:0 S IBDC=$O(^SC("AC","C",IBDC)) Q:'IBDC I $D(^SC(IBDC,0)),$P(^(0),"^",17)="N" F I=IBBEG-.0001:0 S I=$O(^SC(IBDC,"S",I)) Q:'I!(I>(IBEND+.99)) F IBDFN=0:0 S IBDFN=$O(^SC(IBDC,"S",I,1,IBDFN)) Q:IBDFN<1 D CLIN1
Q
;
CLIN1 I $D(^SC(IBDC,"S",I,1,IBDFN,0)) S IBAPPT=^(0),DFN=+IBAPPT I $P(IBAPPT,"^",9)'="C",$D(^DPT(DFN,"S",I,0)),$P(^(0),"^",2)']"",$$RPT^IBEFUNC(+$P(^(0),"^",16),I) S IBOE=$P(^DPT(DFN,"S",I,0),"^",20),IBDV=$P(^SC(IBDC,0),"^",15) D STOPS,PROC
Q
;
STOPS ; -finds stops
N X
S X=$G(^DPT(DFN,"S",I,0)) S IBSTOP="Clinic: "_$P(^SC(IBDC,0),"^")_"^"
I X'="" S IBSTOP=IBSTOP_$S(+$P(X,"^",3):"LAB^",1:"")_$S(+$P(X,"^",4):"X-RAY^",1:"")_$S(+$P(X,"^",5):"EKG^",1:"")
Q
;
PROC ; -process each episode of care
I VAUTD'=1 Q:'$D(VAUTD(+IBDV))
I VAUTD=1 Q:'+IBDV
D PTCHK Q:'IBFLAG ; -is patient a vet and have ins data
D INS Q:'IBFLAG ; -is insurance valid for date of care
K IBRMARK
D TRACK^IBCONS3 ; -find tracking entry get reason not billable
D BILL,SET ; -on billed or unbilled list
Q
;
INS ;S IBINDT=I D ^IBCNS S IBFLAG=$S('$D(IBINS):0,1:IBINS)
S IBFLAG=$$INSURED^IBCNS1(DFN,I)
Q
;
PTCHK S IBFLAG=0 I $D(^DPT(+DFN,.312)),$G(^("VET"))="Y" S IBFLAG=1
Q
;
SET N TERMD,DPT0,SSN S DPT0=$G(^DPT(+DFN,0)),SSN=$P(DPT0,"^",9)
S TERMD=$S(IBTERM:$E(SSN,8,9)_$E(SSN,6,7)_$E(SSN,4,5)_$E(SSN,1,3),1:0)
S ^TMP($J,IBDV,$S(B]"":2,1:1),$S(IBTERM:+TERMD,1:$P(DPT0,"^")),DFN,I)=B I $D(IBSTOP),'$D(^(I,1)) S ^(1)=IBSTOP
I $G(IBRMARK)'="" S ^TMP($J,IBDV,$S(B]"":2,1:1),$S(IBTERM:+TERMD,1:$P(DPT0,"^")),DFN,I,2)=$G(IBRMARK)
K IBSTOP,IBRMARK
Q
;
BILL ; Add to billed list if is insurance bill, not canceled
; if opt, date is in list, if inpt, admission date = event date
;
S B="",I1=$S(IBINPT=2:IBADM,IBINPT:I,1:I\1)
I IBINPT,$D(^DGCR(399,"C",DFN)) F M=0:0 S M=$O(^DGCR(399,"C",DFN,M)) Q:'M I $D(^DGCR(399,M,0)),$P(^(0),"^",13)<7,$P($P(^(0),"^",3),".")=$P(I1,"."),$P(^(0),"^",11)="i" S B=B_M_"^" Q:$L(B)>200
I 'IBINPT,$D(^DGCR(399,"AOPV",DFN,I1)) F M=0:0 S M=$O(^DGCR(399,"AOPV",DFN,I1,M)) Q:'M I $P(^DGCR(399,M,0),"^",13)<7,$P(^(0),"^",11)="i" S B=B_M_"^" Q:$L(B)>200
Q
;
PTF ; if all movements are for sc condition then not billable
;
S IBSC="" Q:'$D(^DGPT(+PTF))
S IBMOV=0 F S IBMOV=$O(^DGPT(PTF,"M",IBMOV)) Q:'IBMOV S IBSC=$P($G(^(IBMOV,0)),"^",18) I IBSC=2!(IBSC="") Q
S IBSC=$S(IBSC=2!(IBSC=""):0,1:1)
Q
DIV ;adds the requested divisions to the report
N IBDIV
I VAUTD'=1 D
.S IBDIV="" F S IBDIV=$O(VAUTD(IBDIV)) Q:'IBDIV S ^TMP($J,IBDIV)=""
I VAUTD=1 D
.S IBDIV="" F S IBDIV=$O(^DG(40.8,IBDIV)) Q:IBDIV']""!(+IBDIV'=IBDIV) I $P($G(^DG(40.8,IBDIV,0)),"^",1)]"" S ^TMP($J,IBDIV)=""
Q
IBCONS2 ;ALB/CPM - NSC W/INSURANCE OUTPUT (CON'T) ; 31-JAN-92
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;
+3 ;MAP TO DGCRONS2
+4 ;
LOOP1 ; Compilation for both Inpatient Admisssion and Discharge reports.
+1 NEW DA,IBADM
+2 DO DIV
+3 FOR I=(IBBEG-.0001):0
SET I=$ORDER(^DGPM(IBSUB,I))
IF 'I!(I>(IBEND+.99))
QUIT
Begin DoDot:1
+4 SET DFN=0
FOR
SET DFN=$ORDER(^DGPM(IBSUB,I,DFN))
IF 'DFN
QUIT
SET DA=+$ORDER(^(DFN,0))
Begin DoDot:2
+5 IF IBINPT=2
SET DA=+$PIECE($GET(^DGPM(DA,0)),"^",14)
SET IBADM=+$GET(^DGPM(DA,0))
+6 SET PTF=$PIECE($GET(^DGPM(DA,0)),"^",16)
+7 SET IBADMVT=DA
+8 SET IBDV=+$PIECE($GET(^DIC(42,+$PIECE($GET(^DGPM(DA,0)),"^",6),0)),"^",11)
End DoDot:2
IF PTF
DO PTF
IF '$GET(IBSC)
IF $GET(IBDV)
DO PROC
KILL IBADMVT
End DoDot:1
+9 QUIT
+10 ;
+11 ;
LOOP2 ; Compilation for the Outpatient report.
+1 DO DIV
DIS FOR I=IBBEG-.0001:0
SET I=$ORDER(^DPT("ADIS",I))
IF 'I!(I>(IBEND+.99))
QUIT
Begin DoDot:1
+1 FOR DFN=0:0
SET DFN=$ORDER(^DPT("ADIS",I,DFN))
IF 'DFN
QUIT
SET J=$ORDER(^(DFN,0))
Begin DoDot:2
+2 SET IBOE=""
IF $DATA(^DPT(DFN,"DIS",J,0))
SET IBOE=$PIECE($GET(^DPT(DFN,"DIS",J,0)),"^",18)
+3 IF $DATA(^DPT(DFN,"DIS",J,0))
IF $PIECE(^(0),U,2)<2
SET IBSTOP="Registration: "_$PIECE($GET(^DIC(37,+$PIECE(^(0),U,7),0)),"^")
SET IBDV=$PIECE(^DPT(DFN,"DIS",J,0),"^",4)
DO PROC
End DoDot:2
End DoDot:1
+4 ;
ADD FOR I=IBBEG-.0001:0
SET I=$ORDER(^SDV(I))
IF 'I!(I>(IBEND+.99))
QUIT
SET X=$GET(^(I,0))
Begin DoDot:1
+1 KILL IBOE
+2 SET DFN=$PIECE(X,"^",2)
SET IBDV=$PIECE(X,"^",3)
IF '$DATA(^DPT(+DFN,0))
QUIT
+3 FOR N=0:0
SET N=$ORDER(^SDV(I,"CS",N))
IF 'N
QUIT
IF $$RPT^IBEFUNC(+$PIECE($GET(^(N,0)),"^",5),I)
Begin DoDot:2
+4 SET IBOE=$GET(IBOE)_$PIECE($GET(^SDV(I,"CS",N,0)),"^",8)_"^"
+5 NEW X
SET X=0
+6 SET IBSTOP="Add/Edit Stop Code^"
+7 FOR
SET X=$ORDER(^SDV(I,"CS","B",X))
IF 'X
QUIT
SET IBSTOP=IBSTOP_$PIECE($GET(^DIC(40.7,+X,0)),"^",2)_"^"
End DoDot:2
DO PROC
QUIT
End DoDot:1
+8 ;
CLIN FOR IBDC=0:0
SET IBDC=$ORDER(^SC("AC","C",IBDC))
IF 'IBDC
QUIT
IF $DATA(^SC(IBDC,0))
IF $PIECE(^(0),"^",17)="N"
FOR I=IBBEG-.0001:0
SET I=$ORDER(^SC(IBDC,"S",I))
IF 'I!(I>(IBEND+.99))
QUIT
FOR IBDFN=0:0
SET IBDFN=$ORDER(^SC(IBDC,"S",I,1,IBDFN))
IF IBDFN<1
QUIT
DO CLIN1
+1 QUIT
+2 ;
CLIN1 IF $DATA(^SC(IBDC,"S",I,1,IBDFN,0))
SET IBAPPT=^(0)
SET DFN=+IBAPPT
IF $PIECE(IBAPPT,"^",9)'="C"
IF $DATA(^DPT(DFN,"S",I,0))
IF $PIECE(^(0),"^",2)']""
IF $$RPT^IBEFUNC(+$PIECE(^(0),"^",16),I)
SET IBOE=$PIECE(^DPT(DFN,"S",I,0),"^",20)
SET IBDV=$PIECE(^SC(IBDC,0),"^",15)
DO STOPS
DO PROC
+1 QUIT
+2 ;
STOPS ; -finds stops
+1 NEW X
+2 SET X=$GET(^DPT(DFN,"S",I,0))
SET IBSTOP="Clinic: "_$PIECE(^SC(IBDC,0),"^")_"^"
+3 IF X'=""
SET IBSTOP=IBSTOP_$SELECT(+$PIECE(X,"^",3):"LAB^",1:"")_$SELECT(+$PIECE(X,"^",4):"X-RAY^",1:"")_$SELECT(+$PIECE(X,"^",5):"EKG^",1:"")
+4 QUIT
+5 ;
PROC ; -process each episode of care
+1 IF VAUTD'=1
IF '$DATA(VAUTD(+IBDV))
QUIT
+2 IF VAUTD=1
IF '+IBDV
QUIT
+3 ; -is patient a vet and have ins data
DO PTCHK
IF 'IBFLAG
QUIT
+4 ; -is insurance valid for date of care
DO INS
IF 'IBFLAG
QUIT
+5 KILL IBRMARK
+6 ; -find tracking entry get reason not billable
DO TRACK^IBCONS3
+7 ; -on billed or unbilled list
DO BILL
DO SET
+8 QUIT
+9 ;
INS ;S IBINDT=I D ^IBCNS S IBFLAG=$S('$D(IBINS):0,1:IBINS)
+1 SET IBFLAG=$$INSURED^IBCNS1(DFN,I)
+2 QUIT
+3 ;
PTCHK SET IBFLAG=0
IF $DATA(^DPT(+DFN,.312))
IF $GET(^("VET"))="Y"
SET IBFLAG=1
+1 QUIT
+2 ;
SET NEW TERMD,DPT0,SSN
SET DPT0=$GET(^DPT(+DFN,0))
SET SSN=$PIECE(DPT0,"^",9)
+1 SET TERMD=$SELECT(IBTERM:$EXTRACT(SSN,8,9)_$EXTRACT(SSN,6,7)_$EXTRACT(SSN,4,5)_$EXTRACT(SSN,1,3),1:0)
+2 SET ^TMP($JOB,IBDV,$SELECT(B]"":2,1:1),$SELECT(IBTERM:+TERMD,1:$PIECE(DPT0,"^")),DFN,I)=B
IF $DATA(IBSTOP)
IF '$DATA(^(I,1))
SET ^(1)=IBSTOP
+3 IF $GET(IBRMARK)'=""
SET ^TMP($JOB,IBDV,$SELECT(B]"":2,1:1),$SELECT(IBTERM:+TERMD,1:$PIECE(DPT0,"^")),DFN,I,2)=$GET(IBRMARK)
+4 KILL IBSTOP,IBRMARK
+5 QUIT
+6 ;
BILL ; Add to billed list if is insurance bill, not canceled
+1 ; if opt, date is in list, if inpt, admission date = event date
+2 ;
+3 SET B=""
SET I1=$SELECT(IBINPT=2:IBADM,IBINPT:I,1:I\1)
+4 IF IBINPT
IF $DATA(^DGCR(399,"C",DFN))
FOR M=0:0
SET M=$ORDER(^DGCR(399,"C",DFN,M))
IF 'M
QUIT
IF $DATA(^DGCR(399,M,0))
IF $PIECE(^(0),"^",13)<7
IF $PIECE($PIECE(^(0),"^",3),".")=$PIECE(I1,".")
IF $PIECE(^(0),"^",11)="i"
SET B=B_M_"^"
IF $LENGTH(B)>200
QUIT
+5 IF 'IBINPT
IF $DATA(^DGCR(399,"AOPV",DFN,I1))
FOR M=0:0
SET M=$ORDER(^DGCR(399,"AOPV",DFN,I1,M))
IF 'M
QUIT
IF $PIECE(^DGCR(399,M,0),"^",13)<7
IF $PIECE(^(0),"^",11)="i"
SET B=B_M_"^"
IF $LENGTH(B)>200
QUIT
+6 QUIT
+7 ;
PTF ; if all movements are for sc condition then not billable
+1 ;
+2 SET IBSC=""
IF '$DATA(^DGPT(+PTF))
QUIT
+3 SET IBMOV=0
FOR
SET IBMOV=$ORDER(^DGPT(PTF,"M",IBMOV))
IF 'IBMOV
QUIT
SET IBSC=$PIECE($GET(^(IBMOV,0)),"^",18)
IF IBSC=2!(IBSC="")
QUIT
+4 SET IBSC=$SELECT(IBSC=2!(IBSC=""):0,1:1)
+5 QUIT
DIV ;adds the requested divisions to the report
+1 NEW IBDIV
+2 IF VAUTD'=1
Begin DoDot:1
+3 SET IBDIV=""
FOR
SET IBDIV=$ORDER(VAUTD(IBDIV))
IF 'IBDIV
QUIT
SET ^TMP($JOB,IBDIV)=""
End DoDot:1
+4 IF VAUTD=1
Begin DoDot:1
+5 SET IBDIV=""
FOR
SET IBDIV=$ORDER(^DG(40.8,IBDIV))
IF IBDIV']""!(+IBDIV'=IBDIV)
QUIT
IF $PIECE($GET(^DG(40.8,IBDIV,0)),"^",1)]""
SET ^TMP($JOB,IBDIV)=""
End DoDot:1
+6 QUIT
