DGVPTIB5 ;alb/mjk - IBOVOP1 for export with PIMS v5.3; 4/21/93
;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
;
IBOVOP1 ;ALB/RLW - Report of Visits for NSC Outpatients ; 12-JUN-92
;;Version 1.5 ; INTEGRATED BILLING ;**14**; 29-JUL-92
MAIN ; perform report for day(s)
Q ;ihs/cmi/maw 02/08/2012 patch 1014 no IB in IHS so entire routine not needed
D HDR,APPT,STOPCD,REGS,PRINT
K DFN,^TMP("IBOVOP",$J),J,IBAPPT,IBJ
Q
APPT ; scan visits for NSC patients
; field 2="CLINIC APPT"
; field 4=clinic
; field 5=appt type
; field 6=status
S IBCL="",IBSEQ=0,J=""
F S IBCL=$O(^SC("AC","C",IBCL)) Q:IBCL="" S IBFLD4=$P(^SC(IBCL,0),"^") Q:IBFLD4="" S J=IBDATE D
.F S J=$O(^SC(IBCL,"S",J)) Q:$E(J,1,7)'=IBDATE S IBIEN=0 D
..F S IBIEN=$O(^SC(IBCL,"S",J,1,IBIEN)) Q:IBIEN="" S DFN=$P(^(IBIEN,0),"^",1) D
...Q:'$$BIL^DGMTUB(DFN,J)
...Q:'$D(^DPT(DFN,"S",J,0)) S IBSDATA=^(0)
...S ^TMP("IBOVOP",$J,$$FLD1(DFN),"CLINIC APPT",$$FLD3(J),IBSEQ)=$E(IBFLD4,1,16)_"^"_$$FLD5($P(IBSDATA,"^",16))_"^"_$E($P($$STATUS^SDAM1(DFN,J,IBCL,IBSDATA),";",3),1,17)_"^"_DFN
Q
STOPCD ; scan ADD/EDIT STOP CODES for day
; field 2="STOP CODE"
; field 4=stop code
; field 5=appt type
N J S J=IBDATE,IBFLD4="",IBSEQ=0
F S J=$O(^SDV(J)),DFN="" Q:$E(J,1,7)'=IBDATE S DFN=$P(^SDV(J,0),"^",2) I $$BIL^DGMTUB(DFN,J) S IB="" D
.F S IB=$O(^SDV(J,"CS","B",IB)) Q:IB="" S I="",I=$O(^(IB,I)) Q:I="" D
..S IBDATA=^SDV(J,"CS",I,0)
..S ^TMP("IBOVOP",$J,$$FLD1(DFN),"STOP CODE",$$FLD3(J),IBSEQ)=$E($P(^DIC(40.7,$P(IBDATA,"^",1),0),"^"),1,16)_"^"_$$FLD5($P(IBDATA,"^",5))_"^^"_DFN S IBSEQ=(IBSEQ+1)
Q
REGS ; registrations for day
N J S J=IBDATE,IBFLD4="",IBFLD5=""
F S J=$O(^DPT("ADIS",J)) Q:J="" Q:$E(J,1,7)'=IBDATE S DFN="" D
.F S DFN=$O(^DPT("ADIS",J,DFN)) Q:DFN="" D
..S IBAIEN="",IBAIEN=$O(^DPT("ADIS",J,DFN,IBAIEN)) Q:(IBAIEN="")
..S IBDATA=^DPT(DFN,"DIS",IBAIEN,0) Q:($P(IBDATA,"^",2)="2")!('$$BIL^DGMTUB(DFN,$P(IBDATA,"^",6)))
..S IBFLD1=$$FLD1(DFN),IBFLD3=$$FLD3(J),Y=$P(IBDATA,"^",3)
..I Y'="" S C=$P(^DD(2.101,2,0),"^",2) D Y^DIQ
..S IBFLD4=$S($D(Y):Y,1:"")
..S Y=$P(IBDATA,"^",7)
..I Y'="" S C=$P(^DD(2.101,6,0),"^",2) D Y^DIQ
..S IBFLD5=$S($D(Y):Y,1:"")
..S ^TMP("IBOVOP",$J,$$FLD1(DFN),"REGISTRATION",$$FLD3(J),IBSEQ)=$E(IBFLD4,1,16)_"^"_$E(IBFLD5,1,30)_"^^"_DFN
Q
CHRGS ; find OP charges for day, if any.
; build string for print
Q:DFN=""
I $D(^IB("AFDT",DFN,-IBDATE))=10 S IBPRNT="" D
.F S IBPRNT=$O(^IB("AFDT",DFN,-IBDATE,IBPRNT)) Q:(IBPRNT="")!(IBQUIT) S IBIEN="" D
..F S IBIEN=$O(^IB("AD",IBPRNT,IBIEN)) Q:(IBIEN="")!(IBQUIT) S IBDATA=$G(^IB(IBIEN,0)) Q:(IBDATA="") D
...S Y=$P(IBDATA,"^",5),C=$P(^DD(350,.05,0),"^",2) D Y^DIQ S IBSTAT=Y K C,Y
...I $Y>(IOSL-5) D PAUSE^IBOUTL Q:IBQUIT D HDR W !,IBFLD1
...S IBACT=$S($P(^IBE(350.1,$P(IBDATA,"^",3),0),"^",8)'="":$P(^(0),"^",8),1:$P(^(0),"^",1)),IBAMT=$P(IBDATA,"^",7),IBAMT=$S(IBACT["CANCEL":"*($"_IBAMT_")",1:"* $"_IBAMT)
...W !?5,IBAMT,?13,IBACT,?63,IBSTAT S IBLINE=(IBLINE+1)
Q
HDR ; print header
S IBPAGE=IBPAGE+1,IBLINE=5,IBRECNO=1,IBTITLE="Category C Outpatient and Registration Activity for "_$$DAT1^IBOUTL(IBDATE)
I $E(IOST,1,2)["C-"!(IBPAGE>1) W @IOF
W ?(80-$L(IBTITLE))\2,IBTITLE
S IBTITLE="Printed: "_$$DAT1^IBOUTL(DT)
W !?(80-$L(IBTITLE))\2,IBTITLE,?70,"Page: "_IBPAGE K Y
W !!,"Patient/Event",?20,"Time",?26,"Clinic/Stop",?44,"Appt.Type",?63,"(Status)",!
S LINE="",$P(LINE,"-",1,IOM)="" W LINE K LINE
Q
PRINT ; retrieve data for printing
S IBFLD1="",DFN="" I '$D(^TMP("IBOVOP",$J)) W !!,"NONE"
F S IBFLD1=$O(^TMP("IBOVOP",$J,IBFLD1)) Q:(IBFLD1="")!(IBQUIT) W ! D:IBLINE>55 HDR W !,IBFLD1 D D CHRGS Q:IBQUIT
.S IBFLD2="" F S IBFLD2=$O(^TMP("IBOVOP",$J,IBFLD1,IBFLD2)) Q:(IBFLD2="")!(IBQUIT) W !?5,IBFLD2 D
..S IBFLD3="" F S IBFLD3=$O(^TMP("IBOVOP",$J,IBFLD1,IBFLD2,IBFLD3)) Q:(IBFLD3="")!(IBQUIT) D
...S IBSEQ="" F S IBSEQ=$O(^TMP("IBOVOP",$J,IBFLD1,IBFLD2,IBFLD3,IBSEQ)) Q:(IBSEQ="")!(IBQUIT) D
....S IBDATA=^(IBSEQ),IBFLD4=$P(IBDATA,"^",1),IBFLD5=$P(IBDATA,"^",2),IBFLD6=$P(IBDATA,"^",3),DFN=$P(IBDATA,"^",4)
....W ?20,IBFLD3,?26,IBFLD4,?44,IBFLD5,?63,IBFLD6,! S IBFLD4="",IBFLD5="",IBFLD6="",IBLINE=(IBLINE+1)
....I IBLINE>55 D HDR W !,IBFLD1 I $D(^TMP("IBOVOP",$J,IBFLD1,IBFLD2,IBFLD3,IBSEQ+1)) W !?5,IBFLD2
....I $Y>(IOSL-5) D PAUSE^IBOUTL Q:IBQUIT D HDR W !,IBFLD1,!?5,IBFLD2
Q:IBQUIT D PAUSE^IBOUTL
Q
FLD1(DFN) ; patient - get patient name and l-4 ssn id
I '$G(DFN) Q ""
N X S X=$$PT^IBEFUNC(DFN)
Q $E($P(X,"^"),1,20)_" "_$E(X)_$P(X,"^",3)
;
FLD3(Y) ; time - convert date/time to time only, no seconds
I '$G(Y) Q ""
X ^DD("DD") Q $P($P(Y,"@",2),":",1,2)
;
FLD5(I) ; get appointment type name
Q $E($P($G(^SD(409.1,+$G(I),0)),"^",1),1,17)
DGVPTIB5 ;alb/mjk - IBOVOP1 for export with PIMS v5.3; 4/21/93
+1 ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
+2 ;
IBOVOP1 ;ALB/RLW - Report of Visits for NSC Outpatients ; 12-JUN-92
+1 ;;Version 1.5 ; INTEGRATED BILLING ;**14**; 29-JUL-92
MAIN ; perform report for day(s)
+1 ;ihs/cmi/maw 02/08/2012 patch 1014 no IB in IHS so entire routine not needed
QUIT
+2 DO HDR
DO APPT
DO STOPCD
DO REGS
DO PRINT
+3 KILL DFN,^TMP("IBOVOP",$JOB),J,IBAPPT,IBJ
+4 QUIT
APPT ; scan visits for NSC patients
+1 ; field 2="CLINIC APPT"
+2 ; field 4=clinic
+3 ; field 5=appt type
+4 ; field 6=status
+5 SET IBCL=""
SET IBSEQ=0
SET J=""
+6 FOR
SET IBCL=$ORDER(^SC("AC","C",IBCL))
IF IBCL=""
QUIT
SET IBFLD4=$PIECE(^SC(IBCL,0),"^")
IF IBFLD4=""
QUIT
SET J=IBDATE
Begin DoDot:1
+7 FOR
SET J=$ORDER(^SC(IBCL,"S",J))
IF $EXTRACT(J,1,7)'=IBDATE
QUIT
SET IBIEN=0
Begin DoDot:2
+8 FOR
SET IBIEN=$ORDER(^SC(IBCL,"S",J,1,IBIEN))
IF IBIEN=""
QUIT
SET DFN=$PIECE(^(IBIEN,0),"^",1)
Begin DoDot:3
+9 IF '$$BIL^DGMTUB(DFN,J)
QUIT
+10 IF '$DATA(^DPT(DFN,"S",J,0))
QUIT
SET IBSDATA=^(0)
+11 SET ^TMP("IBOVOP",$JOB,$$FLD1(DFN),"CLINIC APPT",$$FLD3(J),IBSEQ)=$EXTRACT(IBFLD4,1,16)_"^"_$$FLD5($PIECE(IBSDATA,"^",16))_"^"_$EXTRACT($PIECE($$STATUS^SDAM1(DFN,J,IBCL,IBSDATA),";",3),1,17)_"^"_DFN
End DoDot:3
End DoDot:2
End DoDot:1
+12 QUIT
STOPCD ; scan ADD/EDIT STOP CODES for day
+1 ; field 2="STOP CODE"
+2 ; field 4=stop code
+3 ; field 5=appt type
+4 NEW J
SET J=IBDATE
SET IBFLD4=""
SET IBSEQ=0
+5 FOR
SET J=$ORDER(^SDV(J))
SET DFN=""
IF $EXTRACT(J,1,7)'=IBDATE
QUIT
SET DFN=$PIECE(^SDV(J,0),"^",2)
IF $$BIL^DGMTUB(DFN,J)
SET IB=""
Begin DoDot:1
+6 FOR
SET IB=$ORDER(^SDV(J,"CS","B",IB))
IF IB=""
QUIT
SET I=""
SET I=$ORDER(^(IB,I))
IF I=""
QUIT
Begin DoDot:2
+7 SET IBDATA=^SDV(J,"CS",I,0)
+8 SET ^TMP("IBOVOP",$JOB,$$FLD1(DFN),"STOP CODE",$$FLD3(J),IBSEQ)=$EXTRACT($PIECE(^DIC(40.7,$PIECE(IBDATA,"^",1),0),"^"),1,16)_"^"_$$FLD5($PIECE(IBDATA,"^",5))_"^^"_DFN
SET IBSEQ=(IBSEQ+1)
End DoDot:2
End DoDot:1
+9 QUIT
REGS ; registrations for day
+1 NEW J
SET J=IBDATE
SET IBFLD4=""
SET IBFLD5=""
+2 FOR
SET J=$ORDER(^DPT("ADIS",J))
IF J=""
QUIT
IF $EXTRACT(J,1,7)'=IBDATE
QUIT
SET DFN=""
Begin DoDot:1
+3 FOR
SET DFN=$ORDER(^DPT("ADIS",J,DFN))
IF DFN=""
QUIT
Begin DoDot:2
+4 SET IBAIEN=""
SET IBAIEN=$ORDER(^DPT("ADIS",J,DFN,IBAIEN))
IF (IBAIEN="")
QUIT
+5 SET IBDATA=^DPT(DFN,"DIS",IBAIEN,0)
IF ($PIECE(IBDATA,"^",2)="2")!('$$BIL^DGMTUB(DFN,$PIECE(IBDATA,"^",6)))
QUIT
+6 SET IBFLD1=$$FLD1(DFN)
SET IBFLD3=$$FLD3(J)
SET Y=$PIECE(IBDATA,"^",3)
+7 IF Y'=""
SET C=$PIECE(^DD(2.101,2,0),"^",2)
DO Y^DIQ
+8 SET IBFLD4=$SELECT($DATA(Y):Y,1:"")
+9 SET Y=$PIECE(IBDATA,"^",7)
+10 IF Y'=""
SET C=$PIECE(^DD(2.101,6,0),"^",2)
DO Y^DIQ
+11 SET IBFLD5=$SELECT($DATA(Y):Y,1:"")
+12 SET ^TMP("IBOVOP",$JOB,$$FLD1(DFN),"REGISTRATION",$$FLD3(J),IBSEQ)=$EXTRACT(IBFLD4,1,16)_"^"_$EXTRACT(IBFLD5,1,30)_"^^"_DFN
End DoDot:2
End DoDot:1
+13 QUIT
CHRGS ; find OP charges for day, if any.
+1 ; build string for print
+2 IF DFN=""
QUIT
+3 IF $DATA(^IB("AFDT",DFN,-IBDATE))=10
SET IBPRNT=""
Begin DoDot:1
+4 FOR
SET IBPRNT=$ORDER(^IB("AFDT",DFN,-IBDATE,IBPRNT))
IF (IBPRNT="")!(IBQUIT)
QUIT
SET IBIEN=""
Begin DoDot:2
+5 FOR
SET IBIEN=$ORDER(^IB("AD",IBPRNT,IBIEN))
IF (IBIEN="")!(IBQUIT)
QUIT
SET IBDATA=$GET(^IB(IBIEN,0))
IF (IBDATA="")
QUIT
Begin DoDot:3
+6 SET Y=$PIECE(IBDATA,"^",5)
SET C=$PIECE(^DD(350,.05,0),"^",2)
DO Y^DIQ
SET IBSTAT=Y
KILL C,Y
+7 IF $Y>(IOSL-5)
DO PAUSE^IBOUTL
IF IBQUIT
QUIT
DO HDR
WRITE !,IBFLD1
+8 SET IBACT=$SELECT($PIECE(^IBE(350.1,$PIECE(IBDATA,"^",3),0),"^",8)'="":$PIECE(^(0),"^",8),1:$PIECE(^(0),"^",1))
SET IBAMT=$PIECE(IBDATA,"^",7)
SET IBAMT=$SELECT(IBACT["CANCEL":"*($"_IBAMT_")",1:"* $"_IBAMT)
+9 WRITE !?5,IBAMT,?13,IBACT,?63,IBSTAT
SET IBLINE=(IBLINE+1)
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
HDR ; print header
+1 SET IBPAGE=IBPAGE+1
SET IBLINE=5
SET IBRECNO=1
SET IBTITLE="Category C Outpatient and Registration Activity for "_$$DAT1^IBOUTL(IBDATE)
+2 IF $EXTRACT(IOST,1,2)["C-"!(IBPAGE>1)
WRITE @IOF
+3 WRITE ?(80-$LENGTH(IBTITLE))\2,IBTITLE
+4 SET IBTITLE="Printed: "_$$DAT1^IBOUTL(DT)
+5 WRITE !?(80-$LENGTH(IBTITLE))\2,IBTITLE,?70,"Page: "_IBPAGE
KILL Y
+6 WRITE !!,"Patient/Event",?20,"Time",?26,"Clinic/Stop",?44,"Appt.Type",?63,"(Status)",!
+7 SET LINE=""
SET $PIECE(LINE,"-",1,IOM)=""
WRITE LINE
KILL LINE
+8 QUIT
PRINT ; retrieve data for printing
+1 SET IBFLD1=""
SET DFN=""
IF '$DATA(^TMP("IBOVOP",$JOB))
WRITE !!,"NONE"
+2 FOR
SET IBFLD1=$ORDER(^TMP("IBOVOP",$JOB,IBFLD1))
IF (IBFLD1="")!(IBQUIT)
QUIT
WRITE !
IF IBLINE>55
DO HDR
WRITE !,IBFLD1
Begin DoDot:1
+3 SET IBFLD2=""
FOR
SET IBFLD2=$ORDER(^TMP("IBOVOP",$JOB,IBFLD1,IBFLD2))
IF (IBFLD2="")!(IBQUIT)
QUIT
WRITE !?5,IBFLD2
Begin DoDot:2
+4 SET IBFLD3=""
FOR
SET IBFLD3=$ORDER(^TMP("IBOVOP",$JOB,IBFLD1,IBFLD2,IBFLD3))
IF (IBFLD3="")!(IBQUIT)
QUIT
Begin DoDot:3
+5 SET IBSEQ=""
FOR
SET IBSEQ=$ORDER(^TMP("IBOVOP",$JOB,IBFLD1,IBFLD2,IBFLD3,IBSEQ))
IF (IBSEQ="")!(IBQUIT)
QUIT
Begin DoDot:4
+6 SET IBDATA=^(IBSEQ)
SET IBFLD4=$PIECE(IBDATA,"^",1)
SET IBFLD5=$PIECE(IBDATA,"^",2)
SET IBFLD6=$PIECE(IBDATA,"^",3)
SET DFN=$PIECE(IBDATA,"^",4)
+7 WRITE ?20,IBFLD3,?26,IBFLD4,?44,IBFLD5,?63,IBFLD6,!
SET IBFLD4=""
SET IBFLD5=""
SET IBFLD6=""
SET IBLINE=(IBLINE+1)
+8 IF IBLINE>55
DO HDR
WRITE !,IBFLD1
IF $DATA(^TMP("IBOVOP",$JOB,IBFLD1,IBFLD2,IBFLD3,IBSEQ+1))
WRITE !?5,IBFLD2
+9 IF $Y>(IOSL-5)
DO PAUSE^IBOUTL
IF IBQUIT
QUIT
DO HDR
WRITE !,IBFLD1,!?5,IBFLD2
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
DO CHRGS
IF IBQUIT
QUIT
+10 IF IBQUIT
QUIT
DO PAUSE^IBOUTL
+11 QUIT
FLD1(DFN) ; patient - get patient name and l-4 ssn id
+1 IF '$GET(DFN)
QUIT ""
+2 NEW X
SET X=$$PT^IBEFUNC(DFN)
+3 QUIT $EXTRACT($PIECE(X,"^"),1,20)_" "_$EXTRACT(X)_$PIECE(X,"^",3)
+4 ;
FLD3(Y) ; time - convert date/time to time only, no seconds
+1 IF '$GET(Y)
QUIT ""
+2 XECUTE ^DD("DD")
QUIT $PIECE($PIECE(Y,"@",2),":",1,2)
+3 ;
FLD5(I) ; get appointment type name
+1 QUIT $EXTRACT($PIECE($GET(^SD(409.1,+$GET(I),0)),"^",1),1,17)
