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

BSDFRL.m

Go to the documentation of this file. 
  1. BSDFRL ; IHS/ANMC/LJF - IHS FILE ROOM LIST ;  
  1.  ;;5.3;PIMS;**1007,1008**;DEC 01, 2006
  1.  ;
  1.  ;cmi/anch/maw 11/22/2006 PATCH 1007 added code in GETAPPT,GATHER,SORTS for item 1007.07
  1.  ;cmi/anch/maw 2/5/2007 PATCH 1007 added code in GATHER to look for appt on same day and print if there
  1.  ;
  1.  NEW BSDDT,VAUTD,VAUTC,BSDSRT,BSDCRI   ;IHS/ITSC/LJF 1/9/2004
  1. DATE ; -- select date
  1.  S BSDDT=$$READ^BDGF("D0^::EX","List Appointments for What Date")
  1.  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^C:BY CLINIC CODE;P:BY PRINCIPAL CLINIC;T:BY TERMINAL DIGIT"
  1.  ;S DIR0="S^N:BY CLINIC NAME;C:BY CLINIC CODE;P:BY PRINCIPAL CLINIC;T:BY TERMINAL DIGIT"  ;IHS/ITSC/LJF 1/9/2004  cmi/anch/maw 11/5/2006 maw orig line item 1007.07 patch 1007
  1.  S DIR0="S^N:BY CLINIC NAME;C:BY CLINIC CODE;P:BY PRINCIPAL CLINIC;T:BY TERMINAL DIGIT;A:BY APPOINTMENT TIME;U:BY PATIENT NAME"  ;cmi/anch/maw 11/5/2006 maw new line item 1007.07 patch 1007
  1.  S DIRA="FILE ROOM LIST SORT ORDER"
  1.  S DIRB=$$GET1^DIQ(9009020.2,+$$DIV^BSDU,.17)
  1.  S BSDSRT=$$READ^BDGF(DIR0,DIRA,DIRB,"^D HELP^BSDFRL")
  1.  ;I "CPT"'[BSDSRT D EXIT Q
  1.  ;I "NCPT"'[BSDSRT D EXIT Q   ;IHS/ITSC/LJF 1/9/2004 cmi/anch/maw 11/5/2006 original line item 1007.07 patch 1007
  1.  I "NCPTAU"'[BSDSRT D EXIT Q   ;cmi/anch/maw 11/5/2006 new line item 1007.07 patch 1007
  1.  ;
  1. CHTRQ ; -- ask to include chart requests                   ;IHS/ITSC/LJF 1/9/2004
  1.  S BSDCRI=$$READ^BDGF("Y","Include CHART REQUESTS","NO")  ;IHS/ITSC/LJF 1/9/2004
  1.  ;
  1. DEVICE ; -- select device
  1.  NEW DGVAR,PGM,POP
  1.  ;S DGVAR="VAUTD#^VAUTC#^BSDSRT^BSDDT",PGM="START^BSDFRL"
  1.  S DGVAR="VAUTD#^VAUTC#^BSDSRT^BSDDT^BSDCRI",PGM="START^BSDFRL"   ;IHS/ITSC/LJF 1/9/2004
  1.  D ZIS^DGUTQ I POP D EXIT Q
  1.  I '$D(IO("Q")) D START^BSDFRL
  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 TODO
  1.  D GATHER,PRINT Q            ;otherwise print to paper
  1.  ;
  1. EN ;EP; -- entry for list manager interface
  1.  NEW VALMCNT D TERM^VALM0
  1.  D EN^VALM("BSDRM FILE ROOM 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)="FILE ROOM LIST FOR APPOINTMENTS & CHART REQUESTS for "
  1.  S VALMHDR(2)=$$SP(10)_VALMHDR(2)_$$FMTE^XLFDT(BSDDT)
  1.  Q
  1.  ;
  1. GATHER ;EP; -- gathers data and sets into display array
  1.  ; build sorted array
  1.  K ^TMP("BSDFRL",$J),^TMP("BSDFRL1",$J)
  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("BSDFRL1",$J,A)) Q:A=""  D
  1.  . ; add sort subheading
  1.  . I BSDSRT'="T" D
  1.  .. ;cmi/anch/maw 11/5/2006 added the next 2 lines for appointment time item 1007.07 patch 1007
  1.  .. I BSDSRT="A" D  Q
  1.  ... D SET("",.BSDLN),SET($$SP(3)_"**"_$$TM($P(A,".",2))_"**",.BSDLN)
  1.  .. ;cmi/anch/maw 11/5/2006 end of mods item 1007.07 patch 1007
  1.  .. D SET("",.BSDLN),SET($$SP(3)_"**"_A_"**",.BSDLN)
  1.  . ;
  1.  . S B=0 F  S B=$O(^TMP("BSDFRL1",$J,A,B)) Q:B=""  D
  1.  .. S C=0 F  S C=$O(^TMP("BSDFRL1",$J,A,B,C)) Q:C=""  D
  1.  ... S D=0 F  S D=$O(^TMP("BSDFRL1",$J,A,B,C,D)) Q:D=""  D
  1.  .... D SET(^TMP("BSDFRL1",$J,A,B,C,D),.BSDLN)
  1.  .... I "ANC"[BSDSRT D CHKOC(A,C,D)  ;cmi/anch/maw 2/5/2007 added to check to see if patient is in another clinic PATCH 1007 item 1007.10
  1.  ;
  1.  S VALMCNT=BSDLN
  1.  K ^TMP("BSDFRL1",$J)
  1.  Q
  1.  ;
  1. CHKOC(CLN,PAT,DATE) ;-- check to see if the patient has another appointment on today
  1.  ;cmi/anch/maw 2/5/2007 added to check for other appointments same day PATCH 1007 item 1007.10
  1.  S DATE=$P(DATE,".")
  1.  N J,K,L,M
  1.  S J=0 F  S J=$O(^TMP("BSDFRL1",$J,J)) Q:J=""  D
  1.  . I J=CLN Q
  1.  . ; add sort subheading
  1.  . S K=0 F  S K=$O(^TMP("BSDFRL1",$J,J,K)) Q:K=""  D
  1.  .. S L=0 F  S L=$O(^TMP("BSDFRL1",$J,J,K,L)) Q:L=""  D
  1.  ... I L'=PAT Q
  1.  ... S M=0 F  S M=$O(^TMP("BSDFRL1",$J,J,K,L,M)) Q:M=""  D
  1.  .... I $P(M,".")'=DATE Q
  1.  .... N SIX
  1.  .... S SIX=$E(^TMP("BSDFRL1",$J,J,K,L,M),1,7)
  1.  .... S $E(^TMP("BSDFRL1",$J,J,K,L,M),1,7)="*OTHER*"
  1.  .... D SET(^TMP("BSDFRL1",$J,J,K,L,M),.BSDLN)
  1.  .... S $E(^TMP("BSDFRL1",$J,J,K,L,M),1,7)=SIX
  1.  Q
  1.  ;
  1. ALL ; -- loop thru all clinics
  1.  NEW BSDCLN,BSDSUB
  1.  S BSDCLN=0 F  S BSDCLN=$O(^SC(BSDCLN)) Q:'BSDCLN  D
  1.  . Q:'$$OKAY(BSDCLN)              ;quit if not okay for file room list
  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.  . F BSDSUB="S","C" D GETAPPT          ;get all appt & chart requests
  1.  Q
  1.  ;
  1. SOME ; -- loop thru selected clinics
  1.  NEW BSDCL,BSDCLN,BSDSUB
  1.  S BSDCL=0 F  S BSDCL=$O(VAUTC(BSDCL)) Q:BSDCL=""  D
  1.  . S BSDCLN=VAUTC(BSDCL)          ;clinic ien
  1.  . Q:'$$OKAY(BSDCLN)              ;quit if not okay for file room list
  1.  . Q:'$$ACTV^BSDU(BSDCLN,BSDDT)   ;quit if inactive
  1.  . F BSDSUB="S","C" D GETAPPT     ;get all appt & chart requests
  1.  Q
  1.  ;
  1. GETAPPT ; -- for clinic, get appts & chart requests for date
  1.  I BSDSUB="C",BSDCRI=0 Q   ;don't include chart requests;IHS/ITSC/LJF 1/9/2004
  1.  NEW BSDT,BSDEND,BSDN,NODE,HRCN,TERM,SORT,LINE,X,BSDDFN
  1.  S BSDT=BSDDT-.0001,BSDEND=BSDDT_".2400"
  1.  F  S BSDT=$O(^SC(BSDCLN,BSDSUB,BSDT)) Q:'BSDT  Q:(BSDT>BSDEND)  D
  1.  . S BSDN=0
  1.  . F  S BSDN=$O(^SC(BSDCLN,BSDSUB,BSDT,1,BSDN)) Q:'BSDN  D
  1.  .. S NODE=$G(^SC(BSDCLN,BSDSUB,BSDT,1,BSDN,0)) Q:'NODE
  1.  .. ;
  1.  .. ; set sort values
  1.  .. S BSDDFN=$P(NODE,U)                            ;cmi/anch/maw 11/7/2006 patient dfn item 1007.09 patch 1007
  1.  .. I BSDSRT="N" S SORT=$$GET1^DIQ(44,BSDCLN,.01)  ;clinic name
  1.  .. I BSDSRT="C" S SORT=$$CLNCODE^BSDU(BSDCLN)     ;clinic code
  1.  .. I BSDSRT="P" S SORT=$$PRIN^BSDU(BSDCLN)        ;principal clinic
  1.  .. I BSDSRT="U" S SORT=$$GET1^DIQ(2,BSDDFN,.01)  ;patient name cmi/anch/maw 11/5/2006 item 1007.07 patch 1007
  1.  .. I BSDSRT="A" S SORT=BSDT                       ;appointment time cmi/anch/maw 11/5/206 item 1007.07 patch 1007
  1.  .. S HRCN=$$HRCN^BDGF2(+NODE,$$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                       ;terminal digit sort
  1.  .. ;
  1.  .. ; set display line
  1.  .. S LINE=$J(HRCN,7)_"  "_$E($$GET1^DIQ(2,+NODE,.01),1,20)      ;pat
  1.  .. ;S LINE=$$PAD(LINE,33)_"DOB: "_$$DOB(+NODE)                  ;dob  cmi/anch/maw 11/5/2006 removed dob item 1007.09 patch 1007
  1.  .. S LINE=$$PAD(LINE,33)_$$GET1^DIQ(44,BSDCLN,.01)              ;cln name cmi/anch/maw 11/5/2006 new line item 1007.09 patch 1007
  1.  .. ;S LINE=LINE_"  "_$E($$GET1^DIQ(44,BSDCLN,.01),1,15)         ;cln name cmi/anch/maw 11/5/2006 orig line item 1007.09 patch 1007
  1.  .. I BSDSUB="S" D                                               ;appt time
  1.  ... ;I $P(NODE,U,9)="C" S LINE=$$PAD(LINE,65)_"**CANCELLED**"
  1.  ... I $P(NODE,U,9)="C" S LINE=$$PAD(LINE,58)_"*CANCELLED*"      ;IHS/ITSC/LJF 1/8/2004
  1.  ... ;E  S LINE=$$PAD(LINE,68)_"at "_$P($$FMTE^XLFDT(BSDT),"@",2)  ;cmi/anch/maw 11/5/2006 orig line item 1007.09 patch 1007
  1.  ... E  S LINE=$$PAD(LINE,58)_$P($$FMTE^XLFDT(BSDT),"@",2)  ;cmi/anch/maw 11/5/2006 new line item 1007.09 patch 1007
  1.  ... S LINE=$$PAD(LINE,68)_$$INSUR^BDGF2(BSDDFN,$P(BSDT,"."))  ;cmi/anch/maw 11/7/2006 new line added for insurance item 1007.09 patch 1007
  1.  .. ;I BSDSUB="C" S LINE=$$PAD(LINE,58)_"Cht Req"                 ;chart req cmi/anch/maw 11/7/2006 orig line
  1.  .. I BSDSUB="C" D  ;chart req
  1.  ... S LINE=$$PAD(LINE,58)_"Cht Req"                 ;chart req cmi/anch/maw 11/7/2006 new line for item 1007.09 patch 1007
  1.  ... S LINE=$$PAD(LINE,68)_$$INSUR^BDGF2(BSDDFN,$P(BSDT,"."))  ;cmi/anch/maw 11/7/2006 new line added for insurance item 1007.09 patch 1007
  1.  .. ;
  1.  .. S ^TMP("BSDFRL1",$J,SORT,TERM,+NODE,BSDT)=LINE
  1.  .. ;
  1.  .. I $$DEAD^BDGF2(+NODE) S ^TMP("BSDFRL1",$J,SORT,TERM,+NODE,BSDT+.00001)=$$SP(10)_$G(IORVON)_"** Patient Died on "_$$DOD^BDGF2(+NODE)_" **"_$G(IORVOFF)
  1.  ;
  1.  Q
  1.  ;
  1. PRINT ; -- print to paper
  1.  ;IHS/ITSC/WAR 7/30/04 PATCH #1001
  1.  ;U IO D HDR NEW X
  1.  U IO NEW BSDLN
  1.  I BSDSRT="T" D HEADING
  1.  I BSDSRT="U" D HEADING  ;cmi/anch/maw 10/29/2007 patch 1008
  1.  ;S X=0 F  S X=$O(^TMP("BSDFRL",$J,X)) Q:'X  D
  1.  S BSDLN=0 F  S BSDLN=$O(^TMP("BSDFRL",$J,BSDLN)) Q:'BSDLN  D
  1.  . ;I ^TMP("BSDFRL",$J,X,0)["**" D HEADING  ;IHS/ITSC/LJF 1/2/2004
  1.  . ;I ^TMP("BSDFRL",$J,BSDLN,0)["**" D HEADING  cmi/anch/maw 10/29/2007 orig line
  1.  . I ^TMP("BSDFRL",$J,BSDLN,0)["**",BSDSRT'="U" D HEADING  ;cmi/anch/maw 10/29/2007 patch 1008
  1.  . I $Y>(IOSL-4) D HEADING
  1.  . ;W !,^TMP("BSDFRL",$J,X,0)
  1.  . W !,^TMP("BSDFRL",$J,BSDLN,0)
  1.  ;PATCH #1001 END OF CHANGES
  1.  D ^%ZISC,EXIT
  1.  Q
  1.  ;
  1. HEADING ; -- heading for paper report
  1.  NEW X  ;IHS/ITSC/LJF 12/11/2003
  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 !,?3,"HRCN",?9,"Patient Name",?33,"Date of Birth",?50,"Clinic",?68,"Appt Time",!,$$REPEAT^XLFSTR("=",79),!  ;cmi/anch/maw 11/5/2006 orig line item 1007.09 patch 1007
  1.  W !,?3,"HRCN",?9,"Patient Name",?33,"Clinic",?58,"Appt Time",?68,"Insurance",!,$$REPEAT^XLFSTR("=",79),!  ;cmi/anch/maw 11/5/2006 new line item 1007.09 patch 1007
  1.  Q
  1.  ;
  1. EXIT ;
  1.  K ^TMP("BSDFRL",$J) K BSDLN
  1.  Q
  1.  ;
  1. HELP1 ;
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. OKAY(CLN) ; -- returns 1 if okay to use in file room list
  1.  I $$GET1^DIQ(44,CLN,2,"I")'="C" Q 0   ;not a clinic
  1.  NEW X,Y
  1.  S X=$$GET1^DIQ(44,CLN,2502)        ;non-count clinic value
  1.  S Y=$$GET1^DIQ(44,CLN,2502.5)      ;include on file room list value
  1.  ;IHS/ITSC/WAR 5/27/2004 P #1001 added next line
  1.  I X="NO"&(Y="NO") Q 0
  1.  I X'="YES" Q 1                     ;counted clinic
  1.  I Y="YES" Q 1                      ;okay to include
  1.  Q 0                                ;else don't include
  1.  ;
  1. SET(DATA,LINE) ; -- puts data into display array
  1.  S LINE=LINE+1
  1.  S ^TMP("BSDFRL",$J,LINE,0)=DATA
  1.  Q
  1.  ;
  1. HELP ;EP; -- help for SORTS question
  1.  D MSG^BDGF("Enter N to print by Clinic Name then terminal digit",2,0)  ;IHS/ITSC/LJF 1/9/2004
  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)
  1.  ;
  1. TM(T) ; -- cmi/anch/maw 11/5/26 item 1007.07 patch 1007 return trailing zeroes on time
  1.  N I,J,Z
  1.  S Z=(4-$L(T)) F I=1:1:Z S T=T_"0"
  1.  S T=$E(T,1,2)_":"_$E(T,3,4)
  1.  Q T
  1.  ;