Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBDF1B1

IBDF1B1.m

Go to the documentation of this file.
  1. IBDF1B1 ;ALB/CJM - ENCOUNTER FORM PRINT (IBDF1B continued - print encounter forms for selected appts); 3/1/93
  1. ;;3.0;AUTOMATED INFO COLLECTION SYS;**3**;APR 24, 1997
  1. ;
  1. N IBDEVICE,IBQUIT
  1. ;
  1. K DA,D0,X,Y,I
  1. ;
  1. ;set the error trap so workspace in ^TMP is erased in case of abnormal termination of the print job
  1. S X="ERRORTRP^IBDF1B",@^%ZOSF("TRAP")
  1. ;
  1. S IBQUIT=0
  1. D DEVICE^IBDFUA(0,.IBDEVICE)
  1. D:$D(^TMP("IBDF",$J,"D")) ENDV^IBDF1B1B D:$D(^TMP("IBDF",$J,"C")) ENCL^IBDF1B1A
  1. K ^TMP("EARL",$J),^TMP("MULT",$J)
  1. D ENPT
  1. D KPRNTVAR^IBDFUA
  1. K ^TMP("IBDF",$J),^TMP("IB",$J),^TMP("EARL",$J),^TMP("MULT",$J),DA,D0,X,Y,I,IBI
  1. I $D(ZTQUEUED) S ZTREQ="@"
  1. Q
  1. ENPT ;print encounter forms for each appt
  1. ;input ^TMP( - contains appointment data:
  1. ;if IBSRT=1 format is ^TMP("IBDF",$J,"P",division name,clinic name,clinic ien,patient name,dfn,appt)=""
  1. ;if IBSRT=2 format is^TMP("IBDF",$J,"P",division name,terminal digits,dfn,appt)=clinic ien
  1. ;if IBSRT=3 format is ^TMP("IBDF",$J,"P",division name,clinic name,clinic ien,terminal digits,dfn,appt)=""
  1. N DFN,CLNCNAME,IBCLINIC,PNAME,TDIGIT,IBAPPT,IBDIV
  1. ;IBCLINIC=ien of clinic
  1. ;IBSTRTDV is the division to start from in the case of a reprint
  1. ;IBREPRNT is the clinic or terminal digits (1st 4) to start from in case of a reprint
  1. ;
  1. S IBDIV="" F S IBDIV=$O(^TMP("IBDF",$J,"P",IBDIV)) Q:IBQUIT!(IBDIV="") D:(IBDIV=" ")!(IBSTRTDV']IBDIV)
  1. .I IBSRT=2,IBDIV]" " W !,"DIVISION: ",IBDIV,@IOF
  1. .D:IBSRT=1 SORT1
  1. .D:IBSRT=2 SORT2
  1. .D:IBSRT=3 SORT3
  1. D:'IBQUIT TRLR
  1. Q
  1. ;
  1. SORT1 ;case of sort by div/clinic/patient
  1. S CLNCNAME=""
  1. ;check if report was restarted, start is after this clinic
  1. I IBREPRNT]"" I ((IBDIV=" ")!(IBDIV=IBSTRTDV)) S CLNCNAME=$E(IBREPRNT,1,$L(IBREPRNT)-1)
  1. F S CLNCNAME=$O(^TMP("IBDF",$J,"P",IBDIV,CLNCNAME)) Q:CLNCNAME=""!IBQUIT S IBCLINIC="" F S IBCLINIC=$O(^TMP("IBDF",$J,"P",IBDIV,CLNCNAME,IBCLINIC)) Q:'IBCLINIC!IBQUIT D
  1. .D HDRPG($P($G(^SC(IBCLINIC,0)),"^"),IBDIV)
  1. .S PNAME="" F S PNAME=$O(^TMP("IBDF",$J,"P",IBDIV,CLNCNAME,IBCLINIC,PNAME)) Q:PNAME=""!IBQUIT S DFN="" F S DFN=$O(^TMP("IBDF",$J,"P",IBDIV,CLNCNAME,IBCLINIC,PNAME,DFN)) Q:'DFN!IBQUIT D
  1. ..S IBAPPT="" F S IBAPPT=$O(^TMP("IBDF",$J,"P",IBDIV,CLNCNAME,IBCLINIC,PNAME,DFN,IBAPPT)) Q:'(+IBAPPT)!IBQUIT D APPT($G(IBDIV),$G(CLNCNAME),$G(IBCLINIC),$G(PNAME),$G(DFN),$G(IBAPPT))
  1. Q
  1. SORT2 ;case of sort by div/terminal digit
  1. S TDIGIT=""
  1. ;check if report was restarted, start is after this terminal digit
  1. I IBREPRNT]"" I ((IBDIV=" ")!(IBDIV=IBSTRTDV)) S TDIGIT=IBREPRNT
  1. F S TDIGIT=$O(^TMP("IBDF",$J,"P",IBDIV,TDIGIT)) Q:TDIGIT=""!IBQUIT D
  1. .S DFN="" F S DFN=$O(^TMP("IBDF",$J,"P",IBDIV,TDIGIT,DFN)) Q:'DFN!IBQUIT D
  1. ..S IBAPPT="" F S IBAPPT=$O(^TMP("IBDF",$J,"P",IBDIV,TDIGIT,DFN,IBAPPT)) Q:'+IBAPPT!IBQUIT D
  1. ...S IBCLINIC=$G(^TMP("IBDF",$J,"P",IBDIV,TDIGIT,DFN,IBAPPT)) Q:'IBCLINIC!IBQUIT D APPT($G(IBDIV),$G(CLNCNAME),$G(IBCLINIC),$G(PNAME),$G(DFN),$G(IBAPPT),$G(TDIGIT))
  1. Q
  1. SORT3 ;case of sort by div/clinic/terminal digits
  1. S CLNCNAME=""
  1. ;check if report was restarted, start is after this CLINIC
  1. I IBREPRNT]"" I ((IBDIV=" ")!(IBDIV=IBSTRTDV)) S CLNCNAME=$E(IBREPRNT,1,$L(IBREPRNT)-1)
  1. F S CLNCNAME=$O(^TMP("IBDF",$J,"P",IBDIV,CLNCNAME)) Q:CLNCNAME=""!IBQUIT S IBCLINIC="" F S IBCLINIC=$O(^TMP("IBDF",$J,"P",IBDIV,CLNCNAME,IBCLINIC)) Q:'IBCLINIC!IBQUIT D
  1. .D HDRPG($P($G(^SC(IBCLINIC,0)),"^"),IBDIV)
  1. .S TDIGIT="" F S TDIGIT=$O(^TMP("IBDF",$J,"P",IBDIV,CLNCNAME,IBCLINIC,TDIGIT)) Q:TDIGIT=""!IBQUIT S DFN="" F S DFN=$O(^TMP("IBDF",$J,"P",IBDIV,CLNCNAME,IBCLINIC,TDIGIT,DFN)) Q:'DFN!IBQUIT D
  1. ..S IBAPPT="" F S IBAPPT=$O(^TMP("IBDF",$J,"P",IBDIV,CLNCNAME,IBCLINIC,TDIGIT,DFN,IBAPPT)) Q:'(+IBAPPT)!IBQUIT D APPT($G(IBDIV),$G(CLNCNAME),$G(IBCLINIC),$G(PNAME),$G(DFN),$G(IBAPPT),$G(TDIGIT))
  1. Q
  1. ;
  1. APPT(IBDIV,CLNCNAME,IBCLINIC,PNAME,DFN,IBAPPT,TDIGIT) ;print everything for single appt
  1. ;input - DFN,IBAPPT,IBCLINIC
  1. I $$S^%ZTLOAD S (ZTSTOP,IBQUIT)=1 W !,"TASK STOPPED AT USER'S REQUEST" Q
  1. D PRNTFRMS^IBDF1B2
  1. D PRNTOTHR^IBDF1B5(IBCLINIC,IBAPPT,DFN)
  1. I $D(^DPT(DFN,"S",IBAPPT,0)) S $P(^DPT(DFN,"S",IBAPPT,0),"^",21)=1 S:IBADDONS $P(^DPT(DFN,"S",IBAPPT,0),"^",22)=1
  1. Q
  1. ;
  1. HDRPG(CLINIC,IBDIV) ;print a header page for clinic
  1. N LN
  1. S LN="BEGINNING TO PRINT ENCOUNTER FORMS FOR "_CLINIC_$S(IBDIV'=" ":" IN "_IBDIV,1:"")_" on "_$E(IBDT,4,5)_"/"_$E(IBDT,6,7)_"/"_$E(IBDT,2,3)
  1. I $Y W @IOF
  1. W !!!!!,?((IOM-$L(LN))\2),LN
  1. W @IOF
  1. W !!
  1. Q
  1. TRLR ;prints a trailer page
  1. N LN
  1. S LN="PRINTING OF ENCOUNTER FORMS IS COMPLETE"_" for "_$E(IBDT,4,5)_"/"_$E(IBDT,6,7)_"/"_$E(IBDT,2,3)
  1. W !!!!!,?((IOM-$L(LN))\2),LN
  1. W @IOF
  1. Q
  1. EARLIEST(DFN,APPT) ;determines if APPT is the earliest appt on the list for DFN
  1. D GETLIST^IBDF1B1A(DFN,IBDT,DIVISION)
  1. I APPT=$O(^TMP("IBDF",$J,"APPT LIST",DFN,""))
  1. Q $T