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