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

BSDAPL.m

Go to the documentation of this file. 
  1. BSDAPL ; IHS/ANMC/LJF - APPTS PRINTED LIST ;  [ 11/02/2004  11:42 AM ]
  1.  ;;5.3;PIMS;**1001,1003**;MAY 28, 2004
  1.  ;IHS/ITSC/WAR 08/24/2004 PATCH 1001 rewrote print on paper to work correctly
  1.  ;IHS/ITSC/LJF 10/25/2004 PATCH 1001 screen out cancelled appointments
  1.  ;             06/10/2005 PATCH 1003 resending routine - some sites have bad copy
  1.  ;
  1.  NEW BSDDT,VAUTD,VAUTC,BSDSRT
  1. DATES ; -- select date
  1.  S BSDDT=$$READ^BDGF("DO^::EX","Select Date") Q:BSDDT<1
  1.  ;
  1. CLINIC ; -- all clinics or selected ones?
  1.  ; if ALL clinics are selected, VAUTC=1
  1.  ;   otherwise the VAUTC array is set and VAUTC=0
  1.  D CLINIC^BSDU(1) I Y<0 D EXIT Q
  1.  ;
  1. SORTS ; -- sort by
  1.  NEW DIR0,DIRA,DIRB
  1.  S DIR0="S^D:BY DATE APPT MADE;C:BY CLINIC CODE;P:BY PRINCIPAL CLINIC;T:BY TERMINAL DIGIT"
  1.  S DIRA="APPT ROUTING SLIPS PRINTED SORT ORDER"
  1.  S BSDSRT=$$READ^BDGF(DIR0,DIRA,"D","^D HELP^BSDAPL")
  1.  I "CPTD"'[BSDSRT D EXIT Q
  1.  ;
  1. DEVICE ; -- select device
  1.  NEW DGVAR,PGM,POP
  1.  D MSG^BDGF("Use wide paper or condensed print if printing to paper",2,1)
  1.  S DGVAR="VAUTD#^VAUTC#^BSDSRT^BSDDT",PGM="START^BSDAPL"
  1.  D ZIS^DGUTQ I POP D EXIT Q
  1.  I '$D(IO("Q")) D START^BSDAPL
  1.  Q
  1.  ;
  1.  ;
  1. START ;EP; entry to report after calling print device
  1.  I $E(IOST,1,2)="C-" D EN Q  ;use listman if using screen
  1.  D GATHER,PRINT Q            ;otherwise print to paper
  1.  ;
  1. EN ;EP; -- entry for list manager interface
  1.  NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
  1.  D EN^VALM("BSDRM APPT PRINTED LIST")
  1.  D CLEAR^VALM1
  1.  Q
  1.  ;
  1. HDR ;EP; -- report heading
  1.  S VALMHDR(1)=$$SP(15)_$$CONF^BDGF
  1.  S VALMHDR(2)=$$SP(25)_"APPT ROUTING SLIPS for "_$$FMTE^XLFDT(BSDDT)
  1.  Q
  1.  ;
  1. GATHER ;EP; -- gathers data and sets into display array
  1.  NEW BSDCNT,BSDNP
  1.  ; build sorted array
  1.  K ^TMP("BSDAPL",$J),^TMP("BSDAPL1",$J)
  1.  S (BSDCNT,BSDNP)=0    ;count and # not printed
  1.  S X=$S(VAUTC=1:"ALL",1:"SOME") D @X
  1.  ;
  1.  ; reset sorted array into display array
  1.  NEW A,B,C,D S BSDLN=0
  1.  S A=0 F  S A=$O(^TMP("BSDAPL1",$J,A)) Q:A=""  D
  1.  . ; add sort subheading
  1.  . I BSDSRT'="T",BSDSRT'="D" D
  1.  .. D SET("",.BSDLN),SET($$SP(23)_"**"_A_"**",.BSDLN)
  1.  . ;
  1.  . S B=0 F  S B=$O(^TMP("BSDAPL1",$J,A,B)) Q:B=""  D
  1.  .. S C=0 F  S C=$O(^TMP("BSDAPL1",$J,A,B,C)) Q:C=""  D
  1.  ... S D=0 F  S D=$O(^TMP("BSDAPL1",$J,A,B,C,D)) Q:D=""  D
  1.  .... D SET(^TMP("BSDAPL1",$J,A,B,C,D),.BSDLN)
  1.  ;
  1.  I BSDCNT>0 D SET("Total Appts: "_BSDCNT_"; Total Not Printed: "_BSDNP,.BSDLN)
  1.  ;
  1.  S VALMCNT=BSDLN
  1.  I 'VALMCNT S VALMCNT=1,^TMP("BSDAPL",$J,1,0)=$$SP(10)_"** NO APPTS FOUND FOR DATE **"
  1.  ;K ^TMP("BSDAPL1",$J)
  1.  Q
  1.  ;
  1. ALL ; -- loop thru all clinics
  1.  NEW BSDCLN
  1.  S BSDCLN=0 F  S BSDCLN=$O(^SC(BSDCLN)) Q:'BSDCLN  D
  1.  . I $$GET1^DIQ(44,BSDCLN,2,"I")'="C" Q   ;not a clinic
  1.  . Q:'$$ACTV^BSDU(BSDCLN,BSDDT)                 ;quit if inactive
  1.  . I VAUTD=0 Q:'$D(VAUTD(+$$DIVC^BSDU(BSDCLN)))  ;quit if not select div
  1.  . D GETAPP         ;get all appointments
  1.  Q
  1.  ;
  1. SOME ; -- loop thru selected clinics
  1.  NEW BSDCL,BSDCLN
  1.  S BSDCL=0 F  S BSDCL=$O(VAUTC(BSDCL)) Q:BSDCL=""  D
  1.  . S BSDCLN=VAUTC(BSDCL)          ;clinic ien
  1.  . I $$GET1^DIQ(44,BSDCLN,2,"I")'="C" Q   ;not a clinic
  1.  . Q:'$$ACTV^BSDU(BSDCLN,BSDDT)   ;quit if inactive
  1.  . D GETAPP    ;get all chart requests
  1.  Q
  1.  ;
  1. GETAPP ; -- for clinic, get appts & chart requests for date
  1.  NEW BSDT,BSDEND,BSDN,PAT,HRCN,TERM,SORT,LINE,X,NODE
  1.  S BSDT=BSDDT-.0001,BSDEND=BSDDT_".2400"
  1.  F  S BSDT=$O(^SC(BSDCLN,"S",BSDT)) Q:'BSDT  Q:(BSDT>BSDEND)  D
  1.  . S BSDN=0
  1.  . F  S BSDN=$O(^SC(BSDCLN,"S",BSDT,1,BSDN)) Q:'BSDN  D
  1.  .. S PAT=+$G(^SC(BSDCLN,"S",BSDT,1,BSDN,0)) Q:'PAT
  1.  .. S NODE=$G(^SC(BSDCLN,"S",BSDT,1,BSDN,0))
  1.  .. Q:$P(NODE,U,9)="C"  ;skip if appt is cancelled;IHS/ITSC/LJF 10/25/2004 PATCH 1001
  1.  .. S NODE2=$G(^DPT(PAT,"S",BSDT,0))
  1.  .. ;
  1.  .. ; set sort values
  1.  .. ;    if sorting by date appt made
  1.  .. I BSDSRT="D" S SORT=+$P(NODE,U,7) S:SORT=0 SORT=+$P(NODE2,U,19)
  1.  .. I BSDSRT="C" S SORT=$$CLNCODE^BSDU(BSDCLN)   ;or clinic code
  1.  .. I BSDSRT="P" S SORT=$$PRIN^BSDU(BSDCLN)      ;or principal clinic
  1.  .. S HRCN=$$HRCN^BDGF2(PAT,$$FAC^BSDU(BSDCLN))  ;chart #
  1.  .. S TERM=$$HRCNT^BDGF2(HRCN)                   ;terminal digit format
  1.  .. I $$GET1^DIQ(9009020.2,+$$DIVC^BSDU(BSDCLN),.18)="NO" D
  1.  ... S TERM=$$HRCND^BDGF2(HRCN)  ;no terminal digit per site param
  1.  .. I BSDSRT="T" S SORT=TERM                     ;or terminal digit
  1.  .. ;
  1.  .. ; set display line
  1.  .. S LINE=$J(HRCN,6)_"  "_$E($$GET1^DIQ(2,PAT,.01),1,18)    ;pat
  1.  .. S LINE=$$PAD(LINE,28)_$$GET1^DIQ(44,BSDCLN,1)         ;cln abbrev
  1.  .. S LINE=$$PAD(LINE,37)_$E($$FMTE^XLFDT($P(NODE,U,7)),1,18)    ;appt made on
  1.  .. S LINE=$$PAD(LINE,57)_$$GET1^DIQ(200,+$P(NODE,U,6),1)  ;appt made by
  1.  .. S LINE=$$PAD(LINE,62)_$E($$FMTE^XLFDT($P(NODE2,U,13)),1,18)  ;printed
  1.  .. ;
  1.  .. ; include on file room list?
  1.  .. I $$GET1^DIQ(44,BSDCLN,2502.5)="NO" D
  1.  ... S LINE=$$PAD(LINE,62)_" **don't print**"
  1.  ... S BSDCNT=BSDCNT+1
  1.  .. ;
  1.  .. ; else, count if not printed yet
  1.  .. E  S BSDCNT=BSDCNT+1 S:$P(NODE2,U,13)="" BSDNP=BSDNP+1   ;counts
  1.  .. ;
  1.  .. S LINE=$$PAD(LINE,82)_$P(NODE,U,4)                    ;deliver to
  1.  .. ;
  1.  .. S ^TMP("BSDAPL1",$J,SORT,TERM,+PAT,BSDT)=LINE
  1.  ;
  1.  Q
  1.  ;
  1. PRINT ; -- print to paper
  1.  ;IHS/ITSC/WAR 08/25/04 PATCH #1001 rewrote subroutine using namespaced variable
  1.  U IO D HEADING NEW BDGLN
  1.  S BDGLN=0 F  S BDGLN=$O(^TMP("BSDAPL",$J,BDGLN)) Q:'BDGLN  D
  1.  . I $Y>(IOSL-4) D HEADING
  1.  . W !,^TMP("BSDAPL",$J,BDGLN,0)
  1.  D ^%ZISC,EXIT
  1.  Q
  1.  ;
  1. HEADING ; -- heading for paper report
  1.  D HDR W @IOF,!,VALMHDR(1),!,VALMHDR(2)
  1.  ;IHS/ITSC/WAR 8/26/04 PATCH #1001 added in Col. headings
  1.  ;W !,?55,"Printed on ",$$FMTE^XLFDT(DT),!,$$REPEAT^XLFSTR("=",79),!
  1.  W !,?2,"HRCN",?8,"Patient Name",?28,"Clinic",?37,"Appt Made On",?57,"By",?62,"Printed On",?82,"Delivery Information",!,$$REPEAT^XLFSTR("=",79),!
  1.  Q
  1.  ;
  1.  ;
  1. EXIT ;
  1.  K ^TMP("BSDAPL",$J) K BSDLN
  1.  Q
  1.  ;
  1. HELP1 ;
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1.  ;
  1. SET(DATA,LINE) ; -- puts data into display array
  1.  S LINE=LINE+1
  1.  S ^TMP("BSDAPL",$J,LINE,0)=DATA
  1.  Q
  1.  ;
  1. HELP ;EP; -- help for SORTS question
  1.  D MSG^BDGF("Enter D to print by date/time the appointment was made.",2,1)
  1.  D MSG^BDGF("Enter C to print by Clinic Code then terminal digit.",2,1)
  1.  D MSG^BDGF("Enter P to print by Principal Clinic then terminal digit.")
  1.  D MSG^BDGF("Enter T to print by Terminal Digit order only",2,1)
  1.  D MSG^BDGF("If your file room does NOT sort by terminal digit",1,0)
  1.  D MSG^BDGF("  AND you set the site parameter that way,",1,0)
  1.  D MSG^BDGF("    then the report will use chart # order.",1,1)
  1.  Q
  1.  ;
  1. DOB(PAT) ; -- return date of birth in numerical format with leading zeros
  1.  NEW X S X=$$GET1^DIQ(2,PAT,.03,"I")
  1.  Q $S('X:"??",1:$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3)))
  1.  ;
  1. PAD(D,L) ;EP -- SUBRTN to pad length of data
  1.  ; -- D=data L=length
  1.  Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)
  1.  ;
  1. SP(N) ; -- SUBRTN to pad N number of spaces
  1.  Q $$PAD(" ",N)