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

BSDROUT2.m

Go to the documentation of this file. 
  1. BSDROUT2 ; IHS/ANMC/LJF - MORE SUBROUTINES ;  [ 10/29/2004  4:59 PM ]
  1.  ;;5.3;PIMS;**1001,1003**;MAY 28, 2004
  1.  ;IHS/ITSC/LJF 06/01/2004 PATCH 1001 fixed logic on range of chart requests
  1.  ;             04/14/2005 PATCH 1003 fixed use of wrong variable
  1.  ;             06/10/2005 PATCH 1003 incomplete chart status display fixed
  1.  ;
  1. HED ;EP -- rerouted from BSDROUT1 if printing short form
  1.  I $G(SDCNT)>0 W @IOF
  1.  W !,"FACILITY: ",$$GET1^DIQ(40.8,$$DIV^BSDU,.01)
  1.  W !?7,"**",$E($$CONF^BSDU,1,25),"**"
  1.  S BSDPG=$G(BSDPG)+1 W !,"PAGE ",BSDPG,?10,"OUTPATIENT ROUTING SLIP"
  1.  ;
  1.  W !,"NAME: ",$$GET1^DIQ(2,DFN,.01)
  1.  W ?30,"HRCN: ",$$HRCN^BDGF2(DFN,+$G(DUZ(2)))
  1.  W !,"DOB:  ",$$GET1^DIQ(2,DFN,.03)
  1.  W ?27,"APPT DT: ",$$FMTE^XLFDT(SDATE,5)
  1.  I $$DEAD^BDGF2(DFN) W !,"** PATIENT DIED ON ",$$DOD^BDGF2(DFN)," **"
  1.  ;
  1.  Q:BSDPG>1       ;rest only needs to be on first page
  1.  ;
  1.  D STATUS(DFN) W !
  1.  Q
  1.  ;
  1. STATUS(DFN) ;EP; -- called to check if patient's chart is incomplete
  1.  ;        or pulled for day surgery
  1.  ; called by BSDROUT1
  1.  NEW X Q:DFN=""
  1.  ;
  1.  I $D(^DPT(DFN,.1)) D
  1.  . W !!,"Current Status:  INPATIENT on ward ",^DPT(DFN,.1)
  1.  ;
  1.  ;IHS/ITSC/LJF 6/10/2005 PATCH 1003 only display once
  1.  NEW FOUND S FOUND=0
  1.  ;S X=0 F  S X=$O(^BDGIC("B",DFN,X)) Q:'X  D
  1.  S X=0 F  S X=$O(^BDGIC("B",DFN,X)) Q:'X  Q:FOUND  D
  1.  . ;
  1.  . Q:$P($G(^BDGIC(X,0)),U,17)]""     ;deleted
  1.  . Q:$P($G(^BDGIC(X,0)),U,14)]""     ;completed
  1.  . S FOUND=1                         ;PATCH 1003 new line
  1.  . W !,"Current Status:  ACTIVE INCOMPLETE CHART"
  1.  . ;I $P($G(^BDGIC(X,0)),U,18)]"" W !?8,$P(^BDGIC(X,0),U,18)  ;comments
  1.  . I $P($G(^BDGIC(X,0)),U,18)]"" W !?17,"(",$P(^BDGIC(X,0),U,18),")"  ;comments
  1.  ;end of PATCH 1003 changes
  1.  ;
  1.  NEW X S X=$O(^ADGDS(DFN,"DS",DT))
  1.  I X]"",X\1=DT W !,"Current Status:  ACTIVE DAY SURGERY PATIENT"
  1.  ;
  1.  NEW DATE,X S DATE=9999999-DT,X=DATE-.0001
  1.  S X=$O(^SRF("AIHS3",DFN,X)) Q:'X
  1.  I X\1=DATE W !,"Current Status:  DAY SURGERY/SDA PATIENT"
  1.  Q
  1.  ;
  1.  ;
  1. CRLOOP ;EP; process chart requests for date
  1.  ; called by BSDROUT for each clinic
  1.  ; assumes VA variables SDREP,SDX,SDSTART,SDSTOP,ORDER,SDATE are set
  1.  NEW CLN,IEN,DFN,BSDX,CRDT
  1.  S CLN=0 F  S CLN=$O(^SC(CLN)) Q:'CLN  D
  1.  . Q:'$$OKAY(CLN)                   ;not on list or inactive
  1.  . S IEN=0
  1.  . F  S IEN=$O(^SC(CLN,"C",SDATE,1,IEN)) Q:'IEN  D
  1.  .. S DFN=+$G(^SC(CLN,"C",SDATE,1,IEN,0)) Q:'DFN
  1.  .. S BSDX=$G(^SC(CLN,"C",SDATE,1,IEN,9999999))   ;IHS data
  1.  .. I 'SDREP,SDX["ADD" Q:$P(BSDX,U,4)]""           ;already printed
  1.  .. D CRSET(CLN,SDATE,DFN,ORDER)
  1.  Q
  1.  ;
  1. CRSET(CLN,DATE,DFN,ORDER) ;EP; process single chart request
  1.  ; called by CRLOOP and by chart request software
  1.  NEW HRCN,TERN,BSDMODE
  1.  ;
  1.  S HRCN=$$HRCN^BDGF2(DFN,+$$FAC^BSDU(CLN))  ;chart #
  1.  S TERM=$$HRCNT^BDGF2(HRCN)                 ;terminal digit format
  1.  I $$GET1^DIQ(9009020.2,+$$DIVC^BSDU(CLN),.18)="NO" D
  1.  . S TERM=$$HRCND^BDGF2(HRCN)               ;use chart # per site param
  1.  ;
  1.  ;set chart request as first item for day-makes extra forms print
  1.  ;too hard to find first cr for patient for day AND hopefully
  1.  ;chart request not being made if patient already has appt
  1.  ;
  1.  S BSDMODE="CR"
  1.  ;
  1.  I ORDER="" D  Q  ;make sure all cr for date are printed
  1.  . I $D(^TMP("SDRS",$J,$$GET1^DIQ(2,DFN,.01)," "_TERM,DFN,DATE)) D
  1.  .. NEW I F I=.01:.01:.99 Q:'$D(^TMP("SDRS",$J,$$GET1^DIQ(2,DFN,.01)," "_TERM,DFN,(DATE+I)))
  1.  .. D NMO^BSDROUT0(DFN,(DATE_I),CLN,TERM,"",1)
  1.  . E  D NMO^BSDROUT0(DFN,DATE,CLN,TERM,"",1)
  1.  ;
  1.  ;IHS/ITSC/LJF 6/1/2004 PATCH #1001 ranges for chart requests
  1.  I ORDER=1,SDSTART]"",SDSTART]$E(TERM,1,2) Q   ;before beginning
  1.  I ORDER=1,SDSTOP]"",$E(TERM,1,2)]SDSTOP Q     ;after end
  1.  ;I ORDER=4,SDSTART]$$GET1^DIQ(2,P,.01) Q   ;before beginning
  1.  ;I ORDER=4,$$GET1^DIQ(2,P,.01)]SDSTOP Q   ;before beginning
  1.  I ORDER=4,SDSTART]"",SDSTART]$$GET1^DIQ(2,DFN,.01) Q   ;before beginning   ;IHS/ITSC/LJF 10/25/2004 PATCH 1003
  1.  I ORDER=4,SDSTOP]"",$$GET1^DIQ(2,DFN,.01)]SDSTOP Q     ;after end of range ;IHS/ITSC/LJF 10/25/2004 PATCH 1003
  1.  ;IHS/ITSC/LJF 6/1/2004 PATCH #1001 END OF CHANGES
  1.  ;
  1.  I ORDER=1 D TDO^BSDROUT0(DFN,DATE,CLN,TERM,"",1) Q
  1.  I ORDER=2 D CLO^BSDROUT0(DFN,DATE,CLN,TERM,"",1) Q
  1.  I ORDER=3 D PCO^BSDROUT0(DFN,DATE,CLN,TERM,"",1) Q
  1.  D NMO^BSDROUT0(DFN,DATE,CLN,TERM,"",1) Q
  1.  Q
  1.  ;
  1.  ;
  1. OKAY(C) ; returns 1 if okay to use this clinic
  1.  ;IHS/ITSC/LJF 4/15/2004 rewrote subroutine
  1.  NEW X
  1.  I VAUTC=0,'$D(VAUTC(C)) Q 0          ;not on list of selected clinics
  1.  I VAUTD=0 S X=$P(^SC(C,0),U,15) I '$D(VAUTD(+X)) Q 0
  1.  S X=$G(^SC(C,"I")) I 'X Q 1          ;active clinic
  1.  I ($P(X,U)>DT)!($P(X,U,2)'>DT) Q 1   ;outside inactive dates
  1.  Q 0                                  ;otherwise don't use
  1.  ;