;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;patient data for a particuar appointment is printed on the top of the check-off sheet
EN ;determine print option from user (print by clinic or by patient)
;***
;S XRTL=$ZU(0),XRTN="IBERS-1" D T0^%ZOSV ;start rt clock
D HOME^%ZIS S IBDT=DT
E1 W @IOF,!,?20,"Print Appointment Check-Off Sheets",!!
S DIR("?")="Enter a code from the list or return to exit.",DIR("B")="Clinic"
S DIR(0)="SO^P:Patient Name;C:Clinic",DIR("A")="Select Appointment by" D ^DIR K DIR G:$D(DIRUT) END S IBC=Y
I IBC="P" S IBSRT=1 G E2
S DIR(0)="SOB^C:Clinic and Patient;T:Terminal Digits",DIR("?")="Enter ""C"" for sorting by Clinic and Patient or ""T"" to sort by Terminal Digits"
S DIR("A")="Sort sheets by",DIR("B")="Clinic" D ^DIR K DIR G:$D(DIRUT) END S IBSRT=$S(Y="T":2,1:1)
E2 D DATE I IBDT'=-1 D @IBC
END G:'$D(^TMP("IBRS",$J)) EXIT
W !,"This report requires 132 columns."
S %ZIS="QM",%ZIS("A")="OUTPUT DEVICE: " D ^%ZIS G:POP EXIT
I $D(IO("Q")) S ZTRTN="^IBERS1",ZTDESC="IB Appointment Check-Off Sheets",ZTSAVE("^TMP(""IBRS"",$J,")="",ZTSAVE("IBSRT")="" D ^%ZTLOAD K IO("Q") D HOME^%ZIS G EXIT
U IO
;***
;I $D(XRT0) S:'$D(XRTN) XRTN="IBERS" D T1^%ZOSV ;stop rt clock
D ^IBERS1
EXIT K ^TMP("IBRS",$J)
;***
;I $D(XRT0) S:'$D(XRTN) XRTN="IBERS" D T1^%ZOSV ;stop rt clock
I $D(ZTQUEUED) S ZTREQ="@" Q
K IBC,IBDT,IBSRT,DTOUT,DUOUT,DIRUT,DIROUT,X,Y D ^%ZISC
Q
;
P ;print by patient - get patient then appointment(s) for date
S DIC="^DPT(",DIC(0)="AEQM" D ^DIC K DIC G:Y<0 ENDP S IBPFN=+Y,IBPNM=$P(Y,"^",2)
S IBDFN(IBPFN)="" D SEARCH S IBNM=IBPNM D DISP
G P
ENDP K IBPFN,IBPNM,IBNM,DTOUT,DUOUT,X,Y
Q
;
C ;print all appointments for a clinic - find division then clinic, print all/some clinics for all/some divisions
D DIVISION^VAUTOMA G:$D(VAUTD)<11&(VAUTD=0) ENDC
S DIC("S")="I +$P(^(0),U,25),$P(^(0),U,3)=""C"",$S(VAUTD:1,$D(VAUTD(+$P(^(0),U,15))):1,'+$P(^(0),U,15)&$D(VAUTD($O(^DG(40.8,0)))):1,1:0)"
S DIC="^SC(",VAUTVB="VAUTC",VAUTNI=2,VAUTSTR="clinic" D FIRST^VAUTOMA K DIC G:$D(VAUTC)<11&(VAUTC=0) ENDC
I VAUTC,VAUTD S ^TMP("IBRS",$J,"D","ALL",IBDT)=""
I VAUTC,'VAUTD S IBDIV="" F IBI=1:1 S IBDIV=$O(VAUTD(IBDIV)) Q:IBDIV="" S ^TMP("IBRS",$J,"D",IBDIV,IBDT)=""
I 'VAUTC S IBCLN="" F IBI=1:1 S IBCLN=$O(VAUTC(IBCLN)) Q:IBCLN="" S ^TMP("IBRS",$J,"C",IBCLN,IBDT)=""
ENDC K VAUTNI,VAUTD,VAUTC,VAUTVB,VAUTSTR,IBDIV,IBCLN,IBI,DIC
Q
;
SEARCH ;get the appointment data on a patient (IBLN=APPT DT^CLINIC^STATUS^APPT TYPE)
S DFN=""
S1 S DFN=$O(IBDFN(DFN)) G:DFN="" ENDS
S (VASD("F"),VASD("T"))=IBDT,VASD("W")=129 D SDA^VADPT I VAERR!'($D(^UTILITY("VASD",$J))) G S1
S IBX="" F IBI=1:1 S IBX=$O(^UTILITY("VASD",$J,IBX)) Q:IBX="" D
. S IBLN=^UTILITY("VASD",$J,IBX,"I") Q:'$P($G(^SC(+$P(IBLN,"^",2),0)),"^",25) S IBPAT=$$PT^IBEFUNC(DFN) Q:IBPAT=""
. S IBTMP($P(IBLN,"^",1))=DFN_"^"_$P(IBLN,"^",2)_"^"_$P(IBPAT,"^",1)_"^"_^UTILITY("VASD",$J,IBX,"E")_"^"_$P(IBPAT,"^",2)
G S1
ENDS K IBX,IBI,IBLN,DFN,IBPAT,VASD,VAERR,IBDFN
Q
;
DISP ;display patients/clinics appointments found and get users choice
I '$D(^UTILITY("VASD",$J)) W !!,?5,"No Active Appointments for ",IBNM," on this date",! G ENDD
I '$D(IBTMP) W !!,?10,"No Active Appointments in a Clinic with a Check-Off Sheet",!,?10,"for ",IBNM," on this date.",! G ENDD
W !!,"Appointments for ",IBNM,!
S IBX="" F IBI=1:1 S IBX=$O(IBTMP(IBX)) Q:IBX="" S IBLN=IBTMP(IBX) W !,$J(IBI,3)," ",$E($S(IBC="C":$P(IBLN,"^",3),1:$P(IBLN,"^",5)),1,20),?25," " F IBJ=4,6,7 W " ",$P(IBLN,"^",IBJ)
S DIR(0)="LO^1:"_(IBI-1)_"^K:X[""."" X",DIR("A")=" Select Appointments" D ^DIR K DIR G:$D(DIRUT) ENDD
S IBX="" F IBI=1:1 S IBX=$O(IBTMP(IBX)) Q:IBX="" I Y[(IBI_",") D
. S IBSRT1=$S(IBSRT=2:0_$$TDG^IBEFUNC2($P(IBTMP(IBX),"^",8)),1:$P(IBTMP(IBX),"^",2))
. S ^TMP("IBRS",$J,"P",IBSRT1,$P(IBTMP(IBX),"^",3),IBX)=IBTMP(IBX)_"^"_IBX
ENDD K IBX,IBI,IBJ,IBLN,IBTMP,IBSRT1,DTOUT,DUOUT,DIRUT,DIROUT,X,Y,^UTILITY("VASD",$J)
Q
;
DATE ;get date for RS
S Y=IBDT X ^DD("DD")
S %DT="AEX",%DT("A")="Appointment DATE: ",%DT("B")=Y D ^%DT K %DT S IBDT=Y
W !!,"Only Clinics and Patients with Appointments on this Date will be allowed."
W !,"Appointments must be in Clinics that have a Check-Off Sheet, to be chosen.",!!
Q
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;patient data for a particuar appointment is printed on the top of the check-off sheet
EN ;determine print option from user (print by clinic or by patient)
+1 ;***
+2 ;S XRTL=$ZU(0),XRTN="IBERS-1" D T0^%ZOSV ;start rt clock
+3 DO HOME^%ZIS
SET IBDT=DT
E1 WRITE @IOF,!,?20,"Print Appointment Check-Off Sheets",!!
+1 SET DIR("?")="Enter a code from the list or return to exit."
SET DIR("B")="Clinic"
+2 SET DIR(0)="SO^P:Patient Name;C:Clinic"
SET DIR("A")="Select Appointment by"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
GOTO END
SET IBC=Y
+3 IF IBC="P"
SET IBSRT=1
GOTO E2
+4 SET DIR(0)="SOB^C:Clinic and Patient;T:Terminal Digits"
SET DIR("?")="Enter ""C"" for sorting by Clinic and Patient or ""T"" to sort by Terminal Digits"
+5 SET DIR("A")="Sort sheets by"
SET DIR("B")="Clinic"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
GOTO END
SET IBSRT=$SELECT(Y="T":2,1:1)
E2 DO DATE
IF IBDT'=-1
DO @IBC
END IF '$DATA(^TMP("IBRS",$JOB))
GOTO EXIT
+1 WRITE !,"This report requires 132 columns."
+2 SET %ZIS="QM"
SET %ZIS("A")="OUTPUT DEVICE: "
DO ^%ZIS
IF POP
GOTO EXIT
+3 IF $DATA(IO("Q"))
SET ZTRTN="^IBERS1"
SET ZTDESC="IB Appointment Check-Off Sheets"
SET ZTSAVE("^TMP(""IBRS"",$J,")=""
SET ZTSAVE("IBSRT")=""
DO ^%ZTLOAD
KILL IO("Q")
DO HOME^%ZIS
GOTO EXIT
+4 USE IO
+5 ;***
+6 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBERS" D T1^%ZOSV ;stop rt clock
+7 DO ^IBERS1
EXIT KILL ^TMP("IBRS",$JOB)
+1 ;***
+2 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBERS" D T1^%ZOSV ;stop rt clock
+3 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+4 KILL IBC,IBDT,IBSRT,DTOUT,DUOUT,DIRUT,DIROUT,X,Y
DO ^%ZISC
+5 QUIT
+6 ;
P ;print by patient - get patient then appointment(s) for date
+1 SET DIC="^DPT("
SET DIC(0)="AEQM"
DO ^DIC
KILL DIC
IF Y<0
GOTO ENDP
SET IBPFN=+Y
SET IBPNM=$PIECE(Y,"^",2)
+2 SET IBDFN(IBPFN)=""
DO SEARCH
SET IBNM=IBPNM
DO DISP
+3 GOTO P
ENDP KILL IBPFN,IBPNM,IBNM,DTOUT,DUOUT,X,Y
+1 QUIT
+2 ;
C ;print all appointments for a clinic - find division then clinic, print all/some clinics for all/some divisions
+1 DO DIVISION^VAUTOMA
IF $DATA(VAUTD)<11&(VAUTD=0)
GOTO ENDC
+2 SET DIC("S")="I +$P">P">P">P">P">P">P">P(^(0),U,25),$P">P">P">P">P">P">P">P(^(0),U,3)=""C"",$S(VAUTD:1,$D(VAUTD(+$P">P">P">P">P">P">P">P(^(0),U,15))):1,'+$P">P">P">P">P">P">P">P(^(0),U,15)&$D(VAUTD($O(^DG(40.8,0)))):1,1:0)"
+3 SET DIC="^SC("
SET VAUTVB="VAUTC"
SET VAUTNI=2
SET VAUTSTR="clinic"
DO FIRST^VAUTOMA
KILL DIC
IF $DATA(VAUTC)<11&(VAUTC=0)
GOTO ENDC
+4 IF VAUTC
IF VAUTD
SET ^TMP("IBRS",$JOB,"D","ALL",IBDT)=""
+5 IF VAUTC
IF 'VAUTD
SET IBDIV=""
FOR IBI=1:1
SET IBDIV=$ORDER(VAUTD(IBDIV))
IF IBDIV=""
QUIT
SET ^TMP("IBRS",$JOB,"D",IBDIV,IBDT)=""
+6 IF 'VAUTC
SET IBCLN=""
FOR IBI=1:1
SET IBCLN=$ORDER(VAUTC(IBCLN))
IF IBCLN=""
QUIT
SET ^TMP("IBRS",$JOB,"C",IBCLN,IBDT)=""
ENDC KILL VAUTNI,VAUTD,VAUTC,VAUTVB,VAUTSTR,IBDIV,IBCLN,IBI,DIC
+1 QUIT
+2 ;
SEARCH ;get the appointment data on a patient (IBLN=APPT DT^CLINIC^STATUS^APPT TYPE)
+1 SET DFN=""
S1 SET DFN=$ORDER(IBDFN(DFN))
IF DFN=""
GOTO ENDS
+1 SET (VASD("F"),VASD("T"))=IBDT
SET VASD("W")=129
DO SDA^VADPT
IF VAERR!'($DATA(^UTILITY("VASD",$JOB)))
GOTO S1
+2 SET IBX=""
FOR IBI=1:1
SET IBX=$ORDER(^UTILITY("VASD",$JOB,IBX))
IF IBX=""
QUIT
Begin DoDot:1
+3 SET IBLN=^UTILITY("VASD",$JOB,IBX,"I")
IF '$PIECE($GET(^SC(+$PIECE(IBLN,"^",2),0)),"^",25)
QUIT
SET IBPAT=$$PT^IBEFUNC(DFN)
IF IBPAT=""
QUIT
+4 SET IBTMP($PIECE(IBLN,"^",1))=DFN_"^"_$PIECE(IBLN,"^",2)_"^"_$PIECE(IBPAT,"^",1)_"^"_^UTILITY("VASD",$JOB,IBX,"E")_"^"_$PIECE(IBPAT,"^",2)
End DoDot:1
+5 GOTO S1
ENDS KILL IBX,IBI,IBLN,DFN,IBPAT,VASD,VAERR,IBDFN
+1 QUIT
+2 ;
DISP ;display patients/clinics appointments found and get users choice
+1 IF '$DATA(^UTILITY("VASD",$JOB))
WRITE !!,?5,"No Active Appointments for ",IBNM," on this date",!
GOTO ENDD
+2 IF '$DATA(IBTMP)
WRITE !!,?10,"No Active Appointments in a Clinic with a Check-Off Sheet",!,?10,"for ",IBNM," on this date.",!
GOTO ENDD
+3 WRITE !!,"Appointments for ",IBNM,!
+4 SET IBX=""
FOR IBI=1:1
SET IBX=$ORDER(IBTMP(IBX))
IF IBX=""
QUIT
SET IBLN=IBTMP(IBX)
WRITE !,$JUSTIFY(IBI,3)," ",$EXTRACT($SELECT(IBC="C":$PIECE(IBLN,"^",3),1:$PIECE(IBLN,"^",5)),1,20),?25," "
FOR IBJ=4,6,7
WRITE " ",$PIECE(IBLN,"^",IBJ)
+5 SET DIR(0)="LO^1:"_(IBI-1)_"^K:X[""."" X"
SET DIR("A")=" Select Appointments"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
GOTO ENDD
+6 SET IBX=""
FOR IBI=1:1
SET IBX=$ORDER(IBTMP(IBX))
IF IBX=""
QUIT
IF Y[(IBI_",")
Begin DoDot:1
+7 SET IBSRT1=$SELECT(IBSRT=2:0_$$TDG^IBEFUNC2($PIECE(IBTMP(IBX),"^",8)),1:$PIECE(IBTMP(IBX),"^",2))
+8 SET ^TMP("IBRS",$JOB,"P",IBSRT1,$PIECE(IBTMP(IBX),"^",3),IBX)=IBTMP(IBX)_"^"_IBX
End DoDot:1
ENDD KILL IBX,IBI,IBJ,IBLN,IBTMP,IBSRT1,DTOUT,DUOUT,DIRUT,DIROUT,X,Y,^UTILITY("VASD",$JOB)
+1 QUIT
+2 ;
DATE ;get date for RS
+1 SET Y=IBDT
XECUTE ^DD("DD")
+2 SET %DT="AEX"
SET %DT("A")="Appointment DATE: "
SET %DT("B")=Y
DO ^%DT
KILL %DT
SET IBDT=Y
+3 WRITE !!,"Only Clinics and Patients with Appointments on this Date will be allowed."
+4 WRITE !,"Appointments must be in Clinics that have a Check-Off Sheet, to be chosen.",!!
+5 QUIT
