IBDF1B1 ;ALB/CJM - ENCOUNTER FORM PRINT (IBDF1B continued - print encounter forms for selected appts); 3/1/93
;;3.0;AUTOMATED INFO COLLECTION SYS;**3**;APR 24, 1997
;
N IBDEVICE,IBQUIT
;
K DA,D0,X,Y,I
;
;set the error trap so workspace in ^TMP is erased in case of abnormal termination of the print job
S X="ERRORTRP^IBDF1B",@^%ZOSF("TRAP")
;
S IBQUIT=0
D DEVICE^IBDFUA(0,.IBDEVICE)
D:$D(^TMP("IBDF",$J,"D")) ENDV^IBDF1B1B D:$D(^TMP("IBDF",$J,"C")) ENCL^IBDF1B1A
K ^TMP("EARL",$J),^TMP("MULT",$J)
D ENPT
D KPRNTVAR^IBDFUA
K ^TMP("IBDF",$J),^TMP("IB",$J),^TMP("EARL",$J),^TMP("MULT",$J),DA,D0,X,Y,I,IBI
I $D(ZTQUEUED) S ZTREQ="@"
Q
ENPT ;print encounter forms for each appt
;input ^TMP( - contains appointment data:
;if IBSRT=1 format is ^TMP("IBDF",$J,"P",division name,clinic name,clinic ien,patient name,dfn,appt)=""
;if IBSRT=2 format is^TMP("IBDF",$J,"P",division name,terminal digits,dfn,appt)=clinic ien
;if IBSRT=3 format is ^TMP("IBDF",$J,"P",division name,clinic name,clinic ien,terminal digits,dfn,appt)=""
N DFN,CLNCNAME,IBCLINIC,PNAME,TDIGIT,IBAPPT,IBDIV
;IBCLINIC=ien of clinic
;IBSTRTDV is the division to start from in the case of a reprint
;IBREPRNT is the clinic or terminal digits (1st 4) to start from in case of a reprint
;
S IBDIV="" F S IBDIV=$O(^TMP("IBDF",$J,"P",IBDIV)) Q:IBQUIT!(IBDIV="") D:(IBDIV=" ")!(IBSTRTDV']IBDIV)
.I IBSRT=2,IBDIV]" " W !,"DIVISION: ",IBDIV,@IOF
.D:IBSRT=1 SORT1
.D:IBSRT=2 SORT2
.D:IBSRT=3 SORT3
D:'IBQUIT TRLR
Q
;
SORT1 ;case of sort by div/clinic/patient
S CLNCNAME=""
;check if report was restarted, start is after this clinic
I IBREPRNT]"" I ((IBDIV=" ")!(IBDIV=IBSTRTDV)) S CLNCNAME=$E(IBREPRNT,1,$L(IBREPRNT)-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
.D HDRPG($P($G(^SC(IBCLINIC,0)),"^"),IBDIV)
.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
..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))
Q
SORT2 ;case of sort by div/terminal digit
S TDIGIT=""
;check if report was restarted, start is after this terminal digit
I IBREPRNT]"" I ((IBDIV=" ")!(IBDIV=IBSTRTDV)) S TDIGIT=IBREPRNT
F S TDIGIT=$O(^TMP("IBDF",$J,"P",IBDIV,TDIGIT)) Q:TDIGIT=""!IBQUIT D
.S DFN="" F S DFN=$O(^TMP("IBDF",$J,"P",IBDIV,TDIGIT,DFN)) Q:'DFN!IBQUIT D
..S IBAPPT="" F S IBAPPT=$O(^TMP("IBDF",$J,"P",IBDIV,TDIGIT,DFN,IBAPPT)) Q:'+IBAPPT!IBQUIT D
...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))
Q
SORT3 ;case of sort by div/clinic/terminal digits
S CLNCNAME=""
;check if report was restarted, start is after this CLINIC
I IBREPRNT]"" I ((IBDIV=" ")!(IBDIV=IBSTRTDV)) S CLNCNAME=$E(IBREPRNT,1,$L(IBREPRNT)-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
.D HDRPG($P($G(^SC(IBCLINIC,0)),"^"),IBDIV)
.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
..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))
Q
;
APPT(IBDIV,CLNCNAME,IBCLINIC,PNAME,DFN,IBAPPT,TDIGIT) ;print everything for single appt
;input - DFN,IBAPPT,IBCLINIC
I $$S^%ZTLOAD S (ZTSTOP,IBQUIT)=1 W !,"TASK STOPPED AT USER'S REQUEST" Q
D PRNTFRMS^IBDF1B2
D PRNTOTHR^IBDF1B5(IBCLINIC,IBAPPT,DFN)
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
Q
;
HDRPG(CLINIC,IBDIV) ;print a header page for clinic
N LN
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)
I $Y W @IOF
W !!!!!,?((IOM-$L(LN))\2),LN
W @IOF
W !!
Q
TRLR ;prints a trailer page
N LN
S LN="PRINTING OF ENCOUNTER FORMS IS COMPLETE"_" for "_$E(IBDT,4,5)_"/"_$E(IBDT,6,7)_"/"_$E(IBDT,2,3)
W !!!!!,?((IOM-$L(LN))\2),LN
W @IOF
Q
EARLIEST(DFN,APPT) ;determines if APPT is the earliest appt on the list for DFN
D GETLIST^IBDF1B1A(DFN,IBDT,DIVISION)
I APPT=$O(^TMP("IBDF",$J,"APPT LIST",DFN,""))
Q $T
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF1B1 4820 printed Dec 13, 2024@02:51:04 Page 2
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
+2 ;
+3 NEW IBDEVICE,IBQUIT
+4 ;
+5 KILL DA,D0,X,Y,I
+6 ;
+7 ;set the error trap so workspace in ^TMP is erased in case of abnormal termination of the print job
+8 SET X="ERRORTRP^IBDF1B"
SET @^%ZOSF("TRAP")
+9 ;
+10 SET IBQUIT=0
+11 DO DEVICE^IBDFUA(0,.IBDEVICE)
+12 if $DATA(^TMP("IBDF",$JOB,"D"))
DO ENDV^IBDF1B1B
if $DATA(^TMP("IBDF",$JOB,"C"))
DO ENCL^IBDF1B1A
+13 KILL ^TMP("EARL",$JOB),^TMP("MULT",$JOB)
+14 DO ENPT
+15 DO KPRNTVAR^IBDFUA
+16 KILL ^TMP("IBDF",$JOB),^TMP("IB",$JOB),^TMP("EARL",$JOB),^TMP("MULT",$JOB),DA,D0,X,Y,I,IBI
+17 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+18 QUIT
ENPT ;print encounter forms for each appt
+1 ;input ^TMP( - contains appointment data:
+2 ;if IBSRT=1 format is ^TMP("IBDF",$J,"P",division name,clinic name,clinic ien,patient name,dfn,appt)=""
+3 ;if IBSRT=2 format is^TMP("IBDF",$J,"P",division name,terminal digits,dfn,appt)=clinic ien
+4 ;if IBSRT=3 format is ^TMP("IBDF",$J,"P",division name,clinic name,clinic ien,terminal digits,dfn,appt)=""
+5 NEW DFN,CLNCNAME,IBCLINIC,PNAME,TDIGIT,IBAPPT,IBDIV
+6 ;IBCLINIC=ien of clinic
+7 ;IBSTRTDV is the division to start from in the case of a reprint
+8 ;IBREPRNT is the clinic or terminal digits (1st 4) to start from in case of a reprint
+9 ;
+10 SET IBDIV=""
FOR
SET IBDIV=$ORDER(^TMP("IBDF",$JOB,"P",IBDIV))
if IBQUIT!(IBDIV="")
QUIT
if (IBDIV=" ")!(IBSTRTDV']IBDIV)
Begin DoDot:1
+11 IF IBSRT=2
IF IBDIV]" "
WRITE !,"DIVISION: ",IBDIV,@IOF
+12 if IBSRT=1
DO SORT1
+13 if IBSRT=2
DO SORT2
+14 if IBSRT=3
DO SORT3
End DoDot:1
+15 if 'IBQUIT
DO TRLR
+16 QUIT
+17 ;
SORT1 ;case of sort by div/clinic/patient
+1 SET CLNCNAME=""
+2 ;check if report was restarted, start is after this clinic
+3 IF IBREPRNT]""
IF ((IBDIV=" ")!(IBDIV=IBSTRTDV))
SET CLNCNAME=$EXTRACT(IBREPRNT,1,$LENGTH(IBREPRNT)-1)
+4 FOR
SET CLNCNAME=$ORDER(^TMP("IBDF",$JOB,"P",IBDIV,CLNCNAME))
if CLNCNAME=""!IBQUIT
QUIT
SET IBCLINIC=""
FOR
SET IBCLINIC=$ORDER(^TMP("IBDF",$JOB,"P",IBDIV,CLNCNAME,IBCLINIC))
if 'IBCLINIC!IBQUIT
QUIT
Begin DoDot:1
+5 DO HDRPG($PIECE($GET(^SC(IBCLINIC,0)),"^"),IBDIV)
+6 SET PNAME=""
FOR
SET PNAME=$ORDER(^TMP("IBDF",$JOB,"P",IBDIV,CLNCNAME,IBCLINIC,PNAME))
if PNAME=""!IBQUIT
QUIT
SET DFN=""
FOR
SET DFN=$ORDER(^TMP("IBDF",$JOB,"P",IBDIV,CLNCNAME,IBCLINIC,PNAME,DFN))
if 'DFN!IBQUIT
QUIT
Begin DoDot:2
+7 SET IBAPPT=""
FOR
SET IBAPPT=$ORDER(^TMP("IBDF",$JOB,"P",IBDIV,CLNCNAME,IBCLINIC,PNAME,DFN,IBAPPT))
if '(+IBAPPT)!IBQUIT
QUIT
DO APPT($GET(IBDIV),$GET(CLNCNAME),$GET(IBCLINIC),$GET(PNAME),$GET(DFN),$GET(IBAPPT))
End DoDot:2
End DoDot:1
+8 QUIT
SORT2 ;case of sort by div/terminal digit
+1 SET TDIGIT=""
+2 ;check if report was restarted, start is after this terminal digit
+3 IF IBREPRNT]""
IF ((IBDIV=" ")!(IBDIV=IBSTRTDV))
SET TDIGIT=IBREPRNT
+4 FOR
SET TDIGIT=$ORDER(^TMP("IBDF",$JOB,"P",IBDIV,TDIGIT))
if TDIGIT=""!IBQUIT
QUIT
Begin DoDot:1
+5 SET DFN=""
FOR
SET DFN=$ORDER(^TMP("IBDF",$JOB,"P",IBDIV,TDIGIT,DFN))
if 'DFN!IBQUIT
QUIT
Begin DoDot:2
+6 SET IBAPPT=""
FOR
SET IBAPPT=$ORDER(^TMP("IBDF",$JOB,"P",IBDIV,TDIGIT,DFN,IBAPPT))
if '+IBAPPT!IBQUIT
QUIT
Begin DoDot:3
+7 SET IBCLINIC=$GET(^TMP("IBDF",$JOB,"P",IBDIV,TDIGIT,DFN,IBAPPT))
if 'IBCLINIC!IBQUIT
QUIT
DO APPT($GET(IBDIV),$GET(CLNCNAME),$GET(IBCLINIC),$GET(PNAME),$GET(DFN),$GET(IBAPPT),$GET(TDIGIT))
End DoDot:3
End DoDot:2
End DoDot:1
+8 QUIT
SORT3 ;case of sort by div/clinic/terminal digits
+1 SET CLNCNAME=""
+2 ;check if report was restarted, start is after this CLINIC
+3 IF IBREPRNT]""
IF ((IBDIV=" ")!(IBDIV=IBSTRTDV))
SET CLNCNAME=$EXTRACT(IBREPRNT,1,$LENGTH(IBREPRNT)-1)
+4 FOR
SET CLNCNAME=$ORDER(^TMP("IBDF",$JOB,"P",IBDIV,CLNCNAME))
if CLNCNAME=""!IBQUIT
QUIT
SET IBCLINIC=""
FOR
SET IBCLINIC=$ORDER(^TMP("IBDF",$JOB,"P",IBDIV,CLNCNAME,IBCLINIC))
if 'IBCLINIC!IBQUIT
QUIT
Begin DoDot:1
+5 DO HDRPG($PIECE($GET(^SC(IBCLINIC,0)),"^"),IBDIV)
+6 SET TDIGIT=""
FOR
SET TDIGIT=$ORDER(^TMP("IBDF",$JOB,"P",IBDIV,CLNCNAME,IBCLINIC,TDIGIT))
if TDIGIT=""!IBQUIT
QUIT
SET DFN=""
FOR
SET DFN=$ORDER(^TMP("IBDF",$JOB,"P",IBDIV,CLNCNAME,IBCLINIC,TDIGIT,DFN))
if 'DFN!IBQUIT
QUIT
Begin DoDot:2
+7 SET IBAPPT=""
FOR
SET IBAPPT=$ORDER(^TMP("IBDF",$JOB,"P",IBDIV,CLNCNAME,IBCLINIC,TDIGIT,DFN,IBAPPT))
if '(+IBAPPT)!IBQUIT
QUIT
DO APPT($GET(IBDIV),$GET(CLNCNAME),$GET(IBCLINIC),$GET(PNAME),$GET(DFN),$GET(IBAPPT),$GET(TDIGIT))
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
APPT(IBDIV,CLNCNAME,IBCLINIC,PNAME,DFN,IBAPPT,TDIGIT) ;print everything for single appt
+1 ;input - DFN,IBAPPT,IBCLINIC
+2 IF $$S^%ZTLOAD
SET (ZTSTOP,IBQUIT)=1
WRITE !,"TASK STOPPED AT USER'S REQUEST"
QUIT
+3 DO PRNTFRMS^IBDF1B2
+4 DO PRNTOTHR^IBDF1B5(IBCLINIC,IBAPPT,DFN)
+5 IF $DATA(^DPT(DFN,"S",IBAPPT,0))
SET $PIECE(^DPT(DFN,"S",IBAPPT,0),"^",21)=1
if IBADDONS
SET $PIECE(^DPT(DFN,"S",IBAPPT,0),"^",22)=1
+6 QUIT
+7 ;
HDRPG(CLINIC,IBDIV) ;print a header page for clinic
+1 NEW LN
+2 SET LN="BEGINNING TO PRINT ENCOUNTER FORMS FOR "_CLINIC_$SELECT(IBDIV'=" ":" IN "_IBDIV,1:"")_" on "_$EXTRACT(IBDT,4,5)_"/"_$EXTRACT(IBDT,6,7)_"/"_$EXTRACT(IBDT,2,3)
+3 IF $Y
WRITE @IOF
+4 WRITE !!!!!,?((IOM-$LENGTH(LN))\2),LN
+5 WRITE @IOF
+6 WRITE !!
+7 QUIT
TRLR ;prints a trailer page
+1 NEW LN
+2 SET LN="PRINTING OF ENCOUNTER FORMS IS COMPLETE"_" for "_$EXTRACT(IBDT,4,5)_"/"_$EXTRACT(IBDT,6,7)_"/"_$EXTRACT(IBDT,2,3)
+3 WRITE !!!!!,?((IOM-$LENGTH(LN))\2),LN
+4 WRITE @IOF
+5 QUIT
EARLIEST(DFN,APPT) ;determines if APPT is the earliest appt on the list for DFN
+1 DO GETLIST^IBDF1B1A(DFN,IBDT,DIVISION)
+2 IF APPT=$ORDER(^TMP("IBDF",$JOB,"APPT LIST",DFN,""))
+3 QUIT $TEST
