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