- 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 Jan 18, 2025@03:52:15 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