IBERS1 ;ALB/ARH - APPOINTMENT CHECK-OFF SHEET GENERATOR (CONTINUED); 12/6/91
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;***
;S XRTL=$ZU(0),XRTN="IBERS1-2" D T0^%ZOSV ;start rt clock
;
;collect data/print appointment check-off sheets for patients and clinics choosen
;passed in: temp file and IBSRT with the method of sort
S IBQ=0 I $D(^TMP("IBRS",$J,"D")) D ENDV
I 'IBQ,$D(^TMP("IBRS",$J,"C")) D ENCL
I 'IBQ,$D(^TMP("IBRS",$J,"P")) D ENPT
K ^TMP("IBRSC",$J),IBHDR,IBLC,IBQ
;***
;I $D(XRT0) S:'$D(XRTN) XRTN="IBERS1" D T1^%ZOSV ;stop rt clock
I $D(ZTQUEUED) S ZTREQ="@" Q
Q
ENPT ;print an appointment check-off sheet for each patient selected
;input TMP file - contains appointment data:
;^TMP("IBRS",$J,"P",IBSRT1,IBSRT2,IBSRT3)=DFN^CLN/I^PNM/E^APP DT/E^CLN/E^STAT/E^APP TYP/E^PID/E^APP DT/I
S IB1=2,IB4=4,IB2=((IOM-(IB1*2)-IB4)/2),IB3=((IOM-(IB1*2)-(IB4*2))/3)
S IBDSH="" F IBI=1:1:IOM S IBDSH=IBDSH_"-"
S IBSRT1="" F S IBSRT1=$O(^TMP("IBRS",$J,"P",IBSRT1)) Q:IBSRT1=""!(IBQ) S IBSRT2="" D:$D(IBHDR)&(IBSRT=1) HDRPG D
. F S IBSRT2=$O(^TMP("IBRS",$J,"P",IBSRT1,IBSRT2)) Q:IBSRT2=""!(IBQ) S IBSRT3="" D
.. F S IBSRT3=$O(^TMP("IBRS",$J,"P",IBSRT1,IBSRT2,IBSRT3)) Q:IBSRT3=""!(IBQ) D
... S IBLN=^(IBSRT3) D ^IBERS2,PRINT
D:$D(IBHDR) HDRPG
K IBSRT1,IBSRT2,IBSRT3,IBLN,IBDSH,IB1,IB2,IB3,IB4,IBI,IBHDR,IBHDRLN,Y,^TMP("IBRS",$J,"P")
Q
;
ENCL ;for every clinic choosen find every patient appointment on DATE
S IBCNT=1,(IBHDR,IBCLN)=""
F S IBCLN=$O(^TMP("IBRS",$J,"C",IBCLN)) Q:IBCLN=""!IBQ D S IBQ=$$STOP
. S IBY="" F S IBY=$O(^TMP("IBRS",$J,"C",IBCLN,IBY)) Q:IBY="" D
.. S (IBDT,IBAPP)=$E(IBY,1,7) F S IBAPP=$O(^SC(IBCLN,"S",IBAPP)) Q:$E(IBAPP,1,7)'=IBDT D
... S IBCLNE=$P($G(^SC(IBCLN,0)),"^",1),Y=IBAPP X ^DD("DD") S IBDTE=Y
... S IBX=0 F S IBX=$O(^SC(IBCLN,"S",IBAPP,1,IBX)) Q:IBX="" D
.... S IBPFN=+$G(^SC(IBCLN,"S",IBAPP,1,IBX,0)) S IBPAT=$$PT^IBEFUNC(IBPFN) Q:IBPAT=""
.... S IBAPTYP=$G(^DPT(IBPFN,"S",IBAPP,0)) Q:"NT,I,"'[($P(IBAPTYP,"^",2)_",")
.... S IBAPTYP=$P($G(^SD(409.1,+$P(IBAPTYP,"^",16),0)),"^")
.... S IBSRT1=$S(IBSRT=2:0_$$TDG^IBEFUNC2($P(IBPAT,"^",2)),1:IBCLN),IBCNT=IBCNT+1
.... S ^TMP("IBRS",$J,"P",IBSRT1,$P(IBPAT,"^",1),IBAPP)=IBPFN_"^"_IBCLN_"^"_$P(IBPAT,"^",1)_"^"_IBDTE_"^"_IBCLNE_"^^"_IBAPTYP_"^"_$P(IBPAT,"^",2)_"^"_IBAPP
ENDC K IBAPP,IBAPTYP,IBCLN,IBCLNE,IBCNT,IBDT,IBDTE,IBPFN,IBPAT,IBSRT1,IBX,IBY,Y,^TMP("IBRS",$J,"C")
Q
;
ENDV ;entire divisions were choosen, find all clinics (with check-off sheets defined)
I $D(^TMP("IBRS",$J,"D","ALL")) S IBDT="" F S IBDT=$O(^TMP("IBRS",$J,"D","ALL",IBDT)) Q:IBDT="" D
. S IBDIV="" F S IBDIV=$O(^DG(40.8,IBDIV)) Q:IBDIV'?1N.N S ^TMP("IBRS",$J,"D",IBDIV,IBDT)=""
S IBGRP="" F S IBGRP=$O(^SC("AF",IBGRP)) Q:IBGRP=""!IBQ S IBCLN="" D S IBQ=$$STOP
. F S IBCLN=$O(^SC("AF",IBGRP,IBCLN)) Q:IBCLN="" D
.. S IBDIV=$G(^SC(IBCLN,0)) Q:$P(IBDIV,"^",3)'="C"
.. S IBDIV=$P(IBDIV,"^",15) Q:'$D(^TMP("IBRS",$J,"D",+IBDIV))
.. S IBDT="" F S IBDT=$O(^TMP("IBRS",$J,"D",+IBDIV,IBDT)) Q:IBDT="" S ^TMP("IBRS",$J,"C",IBCLN,IBDT)=""
K IBDT,IBCLN,IBDIV,IBGRP,^TMP("IBRS",$J,"D")
Q
;
HDRPG ;print a header/trailer pages if entire clinics or divisions were requested
I $D(IBHDRLN) S IBX=$L(IBHDRLN) W !!!!!!!,$J("End"_IBHDRLN,((IOM\2)+(IBX\2)+2)),@IOF
I IBSRT1'="" S IBX=$G(^SC(IBSRT1,0)),IBHDRLN=" of Check-off sheets for "_$P(IBX,"^",1)_", "_$P($G(^DG(40.8,+$P(IBX,"^",15),0)),"^",1),IBX=$L(IBHDRLN) W !!!!,$J("Beginning"_IBHDRLN,((IOM\2)+(IBX\2)+5)),@IOF
K IBX
Q
;
PRINT ;print the patient data and then the check-off sheet CPT list that has been gathered/created
S IBX="",IBLC=0 S IBQ=$$STOP
F IBI=1:1 S IBX=$O(^TMP("IBRSP",$J,IBX)) Q:IBX=""!(IBQ) S IBLC=IBLC+1 D:IOSL<(IBLC+3) PAUSE W !,^TMP("IBRSP",$J,IBX)
I 'IBQ D PAUSE I 'IBQ S IBX=$G(^SC(+$P(IBLN,"^",2),0)) D CPT^IBERSP(+$P(IBX,"^",25),+$P(IBX,"^",15),IBLC,$P(IBLN,"^",9),0)
W @IOF K ^TMP("IBRSP",$J),IBLC,IBX,IBI
Q
PAUSE ;
Q:$E(IOST,1,2)'["C-" S (IBLC,IBQ)=0,DIR(0)="E" D ^DIR K DIR,DTOUT,DUOUT,DIRUT,DIROUT S:'Y IBQ=1 W @IOF
Q
;
STOP() ;deterimine if user requested task to stop
I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ
Q +$G(ZTSTOP)
IBERS1 ;ALB/ARH - APPOINTMENT CHECK-OFF SHEET GENERATOR (CONTINUED); 12/6/91
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;***
+4 ;S XRTL=$ZU(0),XRTN="IBERS1-2" D T0^%ZOSV ;start rt clock
+5 ;
+6 ;collect data/print appointment check-off sheets for patients and clinics choosen
+7 ;passed in: temp file and IBSRT with the method of sort
+8 SET IBQ=0
IF $DATA(^TMP("IBRS",$JOB,"D"))
DO ENDV
+9 IF 'IBQ
IF $DATA(^TMP("IBRS",$JOB,"C"))
DO ENCL
+10 IF 'IBQ
IF $DATA(^TMP("IBRS",$JOB,"P"))
DO ENPT
+11 KILL ^TMP("IBRSC",$JOB),IBHDR,IBLC,IBQ
+12 ;***
+13 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBERS1" D T1^%ZOSV ;stop rt clock
+14 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+15 QUIT
ENPT ;print an appointment check-off sheet for each patient selected
+1 ;input TMP file - contains appointment data:
+2 ;^TMP("IBRS",$J,"P",IBSRT1,IBSRT2,IBSRT3)=DFN^CLN/I^PNM/E^APP DT/E^CLN/E^STAT/E^APP TYP/E^PID/E^APP DT/I
+3 SET IB1=2
SET IB4=4
SET IB2=((IOM-(IB1*2)-IB4)/2)
SET IB3=((IOM-(IB1*2)-(IB4*2))/3)
+4 SET IBDSH=""
FOR IBI=1:1:IOM
SET IBDSH=IBDSH_"-"
+5 SET IBSRT1=""
FOR
SET IBSRT1=$ORDER(^TMP("IBRS",$JOB,"P",IBSRT1))
IF IBSRT1=""!(IBQ)
QUIT
SET IBSRT2=""
IF $DATA(IBHDR)&(IBSRT=1)
DO HDRPG
Begin DoDot:1
+6 FOR
SET IBSRT2=$ORDER(^TMP("IBRS",$JOB,"P",IBSRT1,IBSRT2))
IF IBSRT2=""!(IBQ)
QUIT
SET IBSRT3=""
Begin DoDot:2
+7 FOR
SET IBSRT3=$ORDER(^TMP("IBRS",$JOB,"P",IBSRT1,IBSRT2,IBSRT3))
IF IBSRT3=""!(IBQ)
QUIT
Begin DoDot:3
+8 SET IBLN=^(IBSRT3)
DO ^IBERS2
DO PRINT
End DoDot:3
End DoDot:2
End DoDot:1
+9 IF $DATA(IBHDR)
DO HDRPG
+10 KILL IBSRT1,IBSRT2,IBSRT3,IBLN,IBDSH,IB1,IB2,IB3,IB4,IBI,IBHDR,IBHDRLN,Y,^TMP("IBRS",$JOB,"P")
+11 QUIT
+12 ;
ENCL ;for every clinic choosen find every patient appointment on DATE
+1 SET IBCNT=1
SET (IBHDR,IBCLN)=""
+2 FOR
SET IBCLN=$ORDER(^TMP("IBRS",$JOB,"C",IBCLN))
IF IBCLN=""!IBQ
QUIT
Begin DoDot:1
+3 SET IBY=""
FOR
SET IBY=$ORDER(^TMP("IBRS",$JOB,"C",IBCLN,IBY))
IF IBY=""
QUIT
Begin DoDot:2
+4 SET (IBDT,IBAPP)=$EXTRACT(IBY,1,7)
FOR
SET IBAPP=$ORDER(^SC(IBCLN,"S",IBAPP))
IF $EXTRACT(IBAPP,1,7)'=IBDT
QUIT
Begin DoDot:3
+5 SET IBCLNE=$PIECE($GET(^SC(IBCLN,0)),"^",1)
SET Y=IBAPP
XECUTE ^DD("DD")
SET IBDTE=Y
+6 SET IBX=0
FOR
SET IBX=$ORDER(^SC(IBCLN,"S",IBAPP,1,IBX))
IF IBX=""
QUIT
Begin DoDot:4
+7 SET IBPFN=+$GET(^SC(IBCLN,"S",IBAPP,1,IBX,0))
SET IBPAT=$$PT^IBEFUNC(IBPFN)
IF IBPAT=""
QUIT
+8 SET IBAPTYP=$GET(^DPT(IBPFN,"S",IBAPP,0))
IF "NT,I,"'[($PIECE(IBAPTYP,"^",2)_",")
QUIT
+9 SET IBAPTYP=$PIECE($GET(^SD(409.1,+$PIECE(IBAPTYP,"^",16),0)),"^")
+10 SET IBSRT1=$SELECT(IBSRT=2:0_$$TDG^IBEFUNC2($PIECE(IBPAT,"^",2)),1:IBCLN)
SET IBCNT=IBCNT+1
+11 SET ^TMP("IBRS",$JOB,"P",IBSRT1,$PIECE(IBPAT,"^",1),IBAPP)=IBPFN_"^"_IBCLN_"^"_$PIECE(IBPAT,"^",1)_"^"_IBDTE_"^"_IBCLNE_"^^"_IBAPTYP_"^"_$PIECE(IBPAT,"^",2)_"^"_IBAPP
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
SET IBQ=$$STOP
ENDC KILL IBAPP,IBAPTYP,IBCLN,IBCLNE,IBCNT,IBDT,IBDTE,IBPFN,IBPAT,IBSRT1,IBX,IBY,Y,^TMP("IBRS",$JOB,"C")
+1 QUIT
+2 ;
ENDV ;entire divisions were choosen, find all clinics (with check-off sheets defined)
+1 IF $DATA(^TMP("IBRS",$JOB,"D","ALL"))
SET IBDT=""
FOR
SET IBDT=$ORDER(^TMP("IBRS",$JOB,"D","ALL",IBDT))
IF IBDT=""
QUIT
Begin DoDot:1
+2 SET IBDIV=""
FOR
SET IBDIV=$ORDER(^DG(40.8,IBDIV))
IF IBDIV'?1N.N
QUIT
SET ^TMP("IBRS",$JOB,"D",IBDIV,IBDT)=""
End DoDot:1
+3 SET IBGRP=""
FOR
SET IBGRP=$ORDER(^SC("AF",IBGRP))
IF IBGRP=""!IBQ
QUIT
SET IBCLN=""
Begin DoDot:1
+4 FOR
SET IBCLN=$ORDER(^SC("AF",IBGRP,IBCLN))
IF IBCLN=""
QUIT
Begin DoDot:2
+5 SET IBDIV=$GET(^SC(IBCLN,0))
IF $PIECE(IBDIV,"^",3)'="C"
QUIT
+6 SET IBDIV=$PIECE(IBDIV,"^",15)
IF '$DATA(^TMP("IBRS",$JOB,"D",+IBDIV))
QUIT
+7 SET IBDT=""
FOR
SET IBDT=$ORDER(^TMP("IBRS",$JOB,"D",+IBDIV,IBDT))
IF IBDT=""
QUIT
SET ^TMP("IBRS",$JOB,"C",IBCLN,IBDT)=""
End DoDot:2
End DoDot:1
SET IBQ=$$STOP
+8 KILL IBDT,IBCLN,IBDIV,IBGRP,^TMP("IBRS",$JOB,"D")
+9 QUIT
+10 ;
HDRPG ;print a header/trailer pages if entire clinics or divisions were requested
+1 IF $DATA(IBHDRLN)
SET IBX=$LENGTH(IBHDRLN)
WRITE !!!!!!!,$JUSTIFY("End"_IBHDRLN,((IOM\2)+(IBX\2)+2)),@IOF
+2 IF IBSRT1'=""
SET IBX=$GET(^SC(IBSRT1,0))
SET IBHDRLN=" of Check-off sheets for "_$PIECE(IBX,"^",1)_", "_$PIECE($GET(^DG(40.8,+$PIECE(IBX,"^",15),0)),"^",1)
SET IBX=$LENGTH(IBHDRLN)
WRITE !!!!,$JUSTIFY("Beginning"_IBHDRLN,((IOM\2)+(IBX\2)+5)),@IOF
+3 KILL IBX
+4 QUIT
+5 ;
PRINT ;print the patient data and then the check-off sheet CPT list that has been gathered/created
+1 SET IBX=""
SET IBLC=0
SET IBQ=$$STOP
+2 FOR IBI=1:1
SET IBX=$ORDER(^TMP("IBRSP",$JOB,IBX))
IF IBX=""!(IBQ)
QUIT
SET IBLC=IBLC+1
IF IOSL<(IBLC+3)
DO PAUSE
WRITE !,^TMP("IBRSP",$JOB,IBX)
+3 IF 'IBQ
DO PAUSE
IF 'IBQ
SET IBX=$GET(^SC(+$PIECE(IBLN,"^",2),0))
DO CPT^IBERSP(+$PIECE(IBX,"^",25),+$PIECE(IBX,"^",15),IBLC,$PIECE(IBLN,"^",9),0)
+4 WRITE @IOF
KILL ^TMP("IBRSP",$JOB),IBLC,IBX,IBI
+5 QUIT
PAUSE ;
+1 IF $EXTRACT(IOST,1,2)'["C-"
QUIT
SET (IBLC,IBQ)=0
SET DIR(0)="E"
DO ^DIR
KILL DIR,DTOUT,DUOUT,DIRUT,DIROUT
IF 'Y
SET IBQ=1
WRITE @IOF
+2 QUIT
+3 ;
STOP() ;deterimine if user requested task to stop
+1 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET ZTSTOP=1
KILL ZTREQ
+2 QUIT +$GET(ZTSTOP)
