- 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)
