BIDUPLT1 ;IHS/CMI/MWR - BI PRINT LETTERS.; MAY 10, 2010
;;8.5;IMMUNIZATION;;SEP 01,2011
;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
;; PRINT LETTERS FROM ^TMP LIST OF PATIENTS.
;
;
;----------
PRINT(BILET,BIDLOC,BIIOP,BIFDT) ;EP
;---> Print Due Letters for patients stored in ^TMP("BIDUL".
;---> Called by PRINTALL above; error checking done above.
;---> Parameters:
; 1 - BILET (req) Due Letter IEN.
; 2 - BIDLOC (req) Date-Location Line of letter.
; 3 - BIIOP (req) Output Device Name (Should be equal to ION.)
; 4 - BIFDT (req) Forecast date.
;
D FULL^VALM1
I '$G(BILET) D ERROR(609) Q
I '$D(^BILET(BILET,0)) D ERROR(610) Q
S:'$D(BIIOP) BIIOP="HOME"
I '$G(BIFDT) D ERROR(616) Q
S BICRT=$S(($E(IOST)="C")!(IOST["BROWSER"):1,1:0)
;
;---> Quit if no patients retrieved. (Next line was v8.0 patch 1.)
I $O(^TMP("BIDUL",$J,0))="" D Q
.U IO
.W !!?3,"NOTE: Based on the criteria you selected, no Immunization Due"
.W !?9,"letters were printed."
.D:BICRT DIRZ^BIUTL3() W:'BICRT @IOF
;
;---> Loop through ^TMP("BIDUL",$J,...,BIDFN) printing Due Letters.
N BIDFN,BILCNT,BIPOP,N,M,P
S BILCNT=0,BIPOP=0
;
S N=0
F S N=$O(^TMP("BIDUL",$J,N)) Q:N="" D Q:BIPOP
.S M=0
.F S M=$O(^TMP("BIDUL",$J,N,M)) Q:M="" D Q:BIPOP
..S P=0
..F S P=$O(^TMP("BIDUL",$J,N,M,P)) Q:P="" D Q:BIPOP
...S BIDFN=0
...F S BIDFN=$O(^TMP("BIDUL",$J,N,M,P,BIDFN)) Q:'BIDFN D Q:BIPOP
....N N,M,P
....S IOP=BIIOP D ^%ZIS
....D PRINT^BILETPR(BIDFN,BILET,BIDLOC,BIIOP,BIFDT,.BIPOP)
....S BILCNT=BILCNT+1
;
S IOP=BIIOP D ^%ZIS
U IO
W !!?10,"Immunization Due Letters printed: ",BILCNT
W !?10,$$NOW^BIUTL5()
D:BICRT DIRZ^BIUTL3() W:'BICRT @IOF
D ^%ZISC
Q
;
;
;----------
ERROR(BIERR) ;EP
;---> Report error, either to screen or print.
;---> Parameters:
; 1 - BIERR (ret) Text of Error Code if any, otherwise null.
;
S:'$G(BIERR) BIERR=999
D ERRCD^BIUTL2(BIERR,,1)
S BIPOP=1
Q
BIDUPLT1 ;IHS/CMI/MWR - BI PRINT LETTERS.; MAY 10, 2010
+1 ;;8.5;IMMUNIZATION;;SEP 01,2011
+2 ;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
+3 ;; PRINT LETTERS FROM ^TMP LIST OF PATIENTS.
+4 ;
+5 ;
+6 ;----------
PRINT(BILET,BIDLOC,BIIOP,BIFDT) ;EP
+1 ;---> Print Due Letters for patients stored in ^TMP("BIDUL".
+2 ;---> Called by PRINTALL above; error checking done above.
+3 ;---> Parameters:
+4 ; 1 - BILET (req) Due Letter IEN.
+5 ; 2 - BIDLOC (req) Date-Location Line of letter.
+6 ; 3 - BIIOP (req) Output Device Name (Should be equal to ION.)
+7 ; 4 - BIFDT (req) Forecast date.
+8 ;
+9 DO FULL^VALM1
+10 IF '$GET(BILET)
DO ERROR(609)
QUIT
+11 IF '$DATA(^BILET(BILET,0))
DO ERROR(610)
QUIT
+12 IF '$DATA(BIIOP)
SET BIIOP="HOME"
+13 IF '$GET(BIFDT)
DO ERROR(616)
QUIT
+14 SET BICRT=$SELECT(($EXTRACT(IOST)="C")!(IOST["BROWSER"):1,1:0)
+15 ;
+16 ;---> Quit if no patients retrieved. (Next line was v8.0 patch 1.)
+17 IF $ORDER(^TMP("BIDUL",$JOB,0))=""
Begin DoDot:1
+18 USE IO
+19 WRITE !!?3,"NOTE: Based on the criteria you selected, no Immunization Due"
+20 WRITE !?9,"letters were printed."
+21 IF BICRT
DO DIRZ^BIUTL3()
IF 'BICRT
WRITE @IOF
End DoDot:1
QUIT
+22 ;
+23 ;---> Loop through ^TMP("BIDUL",$J,...,BIDFN) printing Due Letters.
+24 NEW BIDFN,BILCNT,BIPOP,N,M,P
+25 SET BILCNT=0
SET BIPOP=0
+26 ;
+27 SET N=0
+28 FOR
SET N=$ORDER(^TMP("BIDUL",$JOB,N))
IF N=""
QUIT
Begin DoDot:1
+29 SET M=0
+30 FOR
SET M=$ORDER(^TMP("BIDUL",$JOB,N,M))
IF M=""
QUIT
Begin DoDot:2
+31 SET P=0
+32 FOR
SET P=$ORDER(^TMP("BIDUL",$JOB,N,M,P))
IF P=""
QUIT
Begin DoDot:3
+33 SET BIDFN=0
+34 FOR
SET BIDFN=$ORDER(^TMP("BIDUL",$JOB,N,M,P,BIDFN))
IF 'BIDFN
QUIT
Begin DoDot:4
+35 NEW N,M,P
+36 SET IOP=BIIOP
DO ^%ZIS
+37 DO PRINT^BILETPR(BIDFN,BILET,BIDLOC,BIIOP,BIFDT,.BIPOP)
+38 SET BILCNT=BILCNT+1
End DoDot:4
IF BIPOP
QUIT
End DoDot:3
IF BIPOP
QUIT
End DoDot:2
IF BIPOP
QUIT
End DoDot:1
IF BIPOP
QUIT
+39 ;
+40 SET IOP=BIIOP
DO ^%ZIS
+41 USE IO
+42 WRITE !!?10,"Immunization Due Letters printed: ",BILCNT
+43 WRITE !?10,$$NOW^BIUTL5()
+44 IF BICRT
DO DIRZ^BIUTL3()
IF 'BICRT
WRITE @IOF
+45 DO ^%ZISC
+46 QUIT
+47 ;
+48 ;
+49 ;----------
ERROR(BIERR) ;EP
+1 ;---> Report error, either to screen or print.
+2 ;---> Parameters:
+3 ; 1 - BIERR (ret) Text of Error Code if any, otherwise null.
+4 ;
+5 IF '$GET(BIERR)
SET BIERR=999
+6 DO ERRCD^BIUTL2(BIERR,,1)
+7 SET BIPOP=1
+8 QUIT
