BDGPV ; IHS/ANMC/LJF - PROVIDER INQUIRY ;
;;5.3;PIMS;;APR 26, 2002
;
NEW BDGPV,BDGPVN,DEF,SCR,BDGSRT
S DEF=$S($D(^XUSEC("PROVIDER",DUZ)):$$GET1^DIQ(200,DUZ,.01),1:"")
S SCR="I $D(^XUSEC(""PROVIDER"",+Y))" ;screen for provider key
S BDGPV=$$READ^BDGF("PO^200:EMQZ","Select PROVIDER NAME",DEF,"",SCR)
Q:BDGPV<1 S BDGPVN=$P(BDGPV,U,2),BDGPV=+BDGPV
;
S BDGSRT=$$READ^BDGF("SAO^W:WARD;S:SERVICE","Inpatients sorted by Ward or Service: ","WARD") Q:BDGSRT=U
I $$BROWSE^BDGF="B" D EN Q
D ZIS^BDGF("PQ","START^BDGPV","PROVIDER'S INPATIENTS","BDGPV;BDGPVN;BDGSRT")
Q
;
START ;EP; entry when printing to paper
S BDGPRT=1 D INIT,PRINT Q
;
EN ;EP; -- main entry point for BDG PROVIDER INQUIRY
NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
D EN^VALM("BDG PROVIDER INQUIRY")
D CLEAR^VALM1
Q
;
HDR ; -- header code
S VALMHDR(1)=$$SP(10)_"** "_$$CONF^BDGF_" **"
S VALMHDR(2)=$$SP(75-$L(BDGPVN)\2)_BDGPVN ;provider name
S VALMSG=$$SP(7)_"Attending/Admitting/Primary Care"
Q
;
INIT ; -- init variables and list array
I '$G(BDGPRT) D MSG^BDGF("Please wait while I compile the list...",1,0)
NEW BDGCNT
K ^TMP("BDGPV",$J),^TMP("BDGPV1",$J)
S VALMCNT=0 ;line count
S BDGCNT=1 ;patient count for choosing patient entry
D INPT,SCHADM,DAYSUR,SCHDS,APPTS,SCHVST
I '$D(^TMP("BDGPV",$J)) S ^TMP("BDGPV",$J,1,0)="NO PATIENTS FOUND",VALMCNT=1
K ^TMP("BDGPV1",$J)
Q
;
INPT ; find all inpatients for this provider
NEW BDGCA,DFN,SRT,X,BDGX,LINE,CAT,SRT,NAME
; loop thru ACA xref in ^DPT for current admissions
S BDGCA=0 F S BDGCA=$O(^DPT("ACA",BDGCA)) Q:'BDGCA D
. S DFN=0 F S DFN=$O(^DPT("ACA",BDGCA,DFN)) Q:'DFN D
.. ;
.. ; set admissions into array sorted by category and ward/srv sort
.. S SRT=$S(BDGSRT="W":$G(^DPT(DFN,.1)),1:$$GET1^DIQ(2,DFN,.103))
.. I SRT="" S SRT="??"
.. ;
.. ; category 1: prov is prim inpt prov or attending
.. I $G(^DPT(DFN,.1041))=BDGPV D Q
... S ^TMP("BDGPV1",$J,1,SRT,$$GET1^DIQ(2,DFN,.01),DFN)=BDGCA
.. ;
.. ; category 2: prov is admitting only
.. I $$ADMPRV^BDGF1(BDGCA,DFN,"ADM")=BDGPVN D Q
... S ^TMP("BDGPV1",$J,2,SRT,$$GET1^DIQ(2,DFN,.01),DFN)=BDGCA
.. ;
.. ; category 3: prov is PCP only
.. K BDGX S BDGX="BDGX" D PCP^BSDU1(DFN,.BDGX)
.. I $P(BDGX(1),"/",3)=BDGPV D
... S ^TMP("BDGPV1",$J,3,SRT,$$GET1^DIQ(2,DFN,.01),DFN)=BDGCA
;
; now take sorted list and put into display array
S CAT=0 F S CAT=$O(^TMP("BDGPV1",$J,CAT)) Q:'CAT D
. ;
. ; put category subtitle into display array
. S LINE=$S(CAT=1:"Attending Provider:",CAT=2:"Admitting Provider:",1:"Primary Care Provider")
. D SET($G(IORVON)_LINE_$G(IORVOFF),.VALMCNT,BDGCNT,"")
. ;
. S SRT=0 F S SRT=$O(^TMP("BDGPV1",$J,CAT,SRT)) Q:SRT="" D
.. ;
.. ; put sort item subtitle into display array
.. S LINE="For "_SRT_$S(BDGSRT="W":" Ward",1:" Service")
.. D SET($$SP(3)_$G(IOUON)_LINE_$G(IOUOFF),.VALMCNT,BDGCNT,"")
.. ;
.. S NAME=0 F S NAME=$O(^TMP("BDGPV1",$J,CAT,SRT,NAME)) D:NAME="" SET("",.VALMCNT,BDGCNT,"") Q:NAME="" D
... S DFN=0 F S DFN=$O(^TMP("BDGPV1",$J,CAT,SRT,NAME,DFN)) Q:'DFN D
.... S BDGCA=^TMP("BDGPV1",$J,CAT,SRT,NAME,DFN) ;corresp adm ien
.... ;
.... ; build lines and put into display array
.... S LINE=$J(BDGCNT,2)_") "_$E(NAME,1,18)
.... S LINE=$$PAD(LINE,24)_$J($$HRCN^BDGF2(DFN,DUZ(2)),6)
.... S LINE=$$PAD(LINE,33)_$S(BDGSRT="W":$$SRV,1:$$WRD) ;wrd/srv
.... S LINE=$$PAD(LINE,41)_$G(^DPT(DFN,.101)) ;room-bed
.... S LINE=$$PAD(LINE,50)_$P($$GET1^DIQ(405,BDGCA,.01),"@") ;admit dt
.... S LINE=$$PAD(LINE,64)_$$GET1^DIQ(405,BDGCA,.1) ;dx
.... D SET(LINE,.VALMCNT,BDGCNT,"IP"_U_DFN_U_BDGCA)
.... ;
.... S LINE=$$PAD($$SP(5)_$$CWAD^BDGF2(DFN),17) ;cwad
.... S LINE=LINE_$E($$GET1^DIQ(2,DFN,.1041),1,15)_"/" ;attend
.... S LINE=LINE_$E($$ADMPRV^BDGF1(BDGCA,DFN,"ADM"),1,15)_"/" ;admtg
.... K BDGX S BDGX="BDGX" D PCP^BSDU1(DFN,.BDGX)
.... S LINE=LINE_$E($P($G(BDGX(1)),"/"),1,15) ;pcp
.... D SET(LINE,.VALMCNT,BDGCNT,"IP"_U_DFN_U_BDGCA)
.... ;
.... ; increment patient selection number
.... S BDGCNT=BDGCNT+1
Q
;
SCHADM ; find scheduled admissions for next week for provider
;D SCHED^BDGPV1("IP")
Q
;
DAYSUR ; find all day surgery patients for this provider
I $T(PRVSUR^BSRPEP)]"" D Q
. NEW BDGRR,X,DATE,IEN,BDGI
. K ^TMP("BDGPV1",$J)
. S BDGRR="^TMP(""BDGPV1"",$J)"
. D PRVSUR^BSRPEP(BDGPV,DT,.BDGRR) ;get list from surgery
. I '$D(^TMP("BDGPV1",$J)) Q
. ;
. D SET("Today's Surgeries:",.VALMCNT,BDGCNT,"")
. ;
. I $D(^TMP("BDGPV1",$J)) D
.. S DATE=0 F S DATE=$O(^TMP("BDGPV1",$J,DATE)) Q:'DATE D
... S IEN=0 F S IEN=$O(^TMP("BDGPV1",$J,DATE,IEN)) Q:'IEN D
.... F BDGI=1:1 Q:'$D(^TMP("BDGPV1",$J,DATE,IEN,BDGI)) D
..... S X=$S(BDGI=1:$J(BDGCNT,2)_") ",1:$$SP(4))
..... S X=X_^TMP("BDGPV1",$J,DATE,IEN,BDGI)
..... D SET(X,.VALMCNT,BDGCNT,"SR"_U_IEN)
.... S BDGCNT=BDGCNT+1
. K ^TMP("BDGPV1",$J)
;
;
; look for day surgeries scheduled for today
NEW BDGDT,BDGEND,DFN,IENS,LINE,BDGFRST
S BDGDT=DT-.0001,BDGEND=DT+.24,BDGFRST=1
F S BDGDT=$O(^ADGDS("AA",BDGDT)) Q:'BDGDT Q:BDGDT>BDGEND D
. S DFN=0 F S DFN=$O(^ADGDS("AA",BDGDT,DFN)) Q:'DFN D
.. S BDGDS=0 F S BDGDS=$O(^ADGDS("AA",BDGDT,DFN,BDGDS)) Q:'BDGDS D
... ;
... ; if first on list, display subheading
... I BDGFRST D SET($G(IORVON)_"Today's Day Surgeries:"_$G(IORVOFF),.VALMCNT,BDGCNT,"") S BDGFRST=0
... ;
... ; put today's surgeries into display array
... S IENS=DFN_","_BDGDS
... S LINE=$J(BDGCNT,2)_") "_$P($$GET1^DIQ(9009012.01,IENS,.01),".",2)
... S LINE=$$PAD(LINE,12)_$E($$GET1^DIQ(2,DFN,.01),1,18) ;pat name
... S LINE=$$PAD(LINE,32)_$J($$HRCN^BDGF2(DFN,DUZ(2)),6) ;chart #
... S LINE=$$PAD(LINE,40)_$$GET1^DIQ(9009012.01,IENS,1) ;procedure
... D SET(LINE,.VALMCNT,BDGCNT,"DS"_U_DFN_U_BDGDS)
... ;
... ; build status line with released date/time or other status
... S STATUS="",X=$$GET1^DIQ(9009012.01,IENS,7) I X]"" D
.... S STATUS="Released at "_X
.... I $$GET1^DIQ(9009012.01,IENS,11)="YES" S STATUS=STATUS_" (Admitted)" Q
.... I $$GET1^DIQ(9009012.01,IENS,15)="YES" S STATUS=STATUS_" (Unescorted)"
... ;
... I STATUS="" D
.... I $$GET1^DIQ(9009012.01,IENS,12)="YES" S STATUS="**CANCELLED**" Q
.... I $$GET1^DIQ(9009012.01,IENS,13)="YES" S STATUS="**NO-SHOW**" Q
... ;
... D SET($$SP(10)_STATUS,.VALMCNT,BDGCNT,"DS"_U_DFN_U_BDGDS)
... ;
... ; increment counter
... S BDGCNT=BDGCNT+1
Q
;
SCHDS ; find scheduled day surgeries
;D SCHED^BDGPV1("DS")
Q
;
APPTS ; find all appts for provider for today
NEW BSDPRV,BSDQUIET,BSDDT
S BSDPRV=BDGPV,BSDDT=DT,BSDQUIET=1
D CLINICS^BSDPVD ;sets ^TMP("BSDPV2",$J) array
;
; next lines of code were copied from BSDPVD and modified to fit this
; display array with the proper selelction numbers
K ^TMP("BDGPV1",$J)
;
; loop thru provider's clinics and then appts for date
NEW CLN,CLNM,IEN,DATE,END,NODE
S CLN=0 F S CLN=$O(^TMP("BSDPVD2",$J,CLN)) Q:'CLN D
. S CLNM=$$GET1^DIQ(44,CLN,1) ;clinic abbrievation
. ;
. S DATE=BSDDT-.0001,END=BSDDT_".2400"
. F S DATE=$O(^SC(CLN,"S",DATE)) Q:'DATE Q:(DATE>END) D
.. S IEN=0 F S IEN=$O(^SC(CLN,"S",DATE,1,IEN)) Q:'IEN D
... ;
... ; sort by date,clinic; save clinic ien, patient, length, info
... S NODE=$G(^SC(CLN,"S",DATE,1,IEN,0)) Q:'NODE
... S ^TMP("BDGPV1",$J,DATE,CLNM,IEN)=$P(NODE,U,1,4)_U_CLN_U_$G(^SC(CLN,"S",DATE,1,IEN,"OB"))
;
I '$D(^TMP("BDGPV1",$J)) Q
D SET($G(IORVON)_"Today's Appointments:"_$G(IORVOFF),.VALMCNT,BDGCNT,"")
D SET($$SP(4)_$G(IOUON)_"Appt Time Clinic Patient"_$G(IOUOFF),.VALMCNT,BDGCNT,"")
;
; put sorted list into display array
NEW DATE,CLN,IEN,DATA,LINE,X,I,LAST,ENDTM
S DATE=0 F S DATE=$O(^TMP("BDGPV1",$J,DATE)) Q:'DATE D
. S CLN=0 F S CLN=$O(^TMP("BDGPV1",$J,DATE,CLN)) Q:CLN="" D
.. S IEN=0 F S IEN=$O(^TMP("BDGPV1",$J,DATE,CLN,IEN)) Q:'IEN D
... S DATA=^TMP("BDGPV1",$J,DATE,CLN,IEN)
... S LINE=$J(BDGCNT,2)_") "_$P($$FMTE^XLFDT(DATE,2),"@",2) ;appt time
... S ENDTM=$P($$FMTE^XLFDT($$FMADD^XLFDT(DATE,0,0,$P(DATA,U,2))),"@",2)
... S LINE=LINE_"-"_ENDTM_$TR($P(DATA,U,6),"O","*") ;end time/overbk
... S LINE=$$PAD(LINE,17)_CLN ;end time & clinic
... S LINE=$$PAD(LINE,26)_$E($$GET1^DIQ(2,+DATA,.01),1,18) ;patient
... S LINE=$$PAD(LINE,45)_$J("#"_$$HRCN^BDGF2(+DATA,DUZ(2)),6) ;chart #
... S LINE=$$PAD(LINE,54)_$$CWAD^BDGF2(+DATA) ;cwad
... ;
... ; add extra lines if end time diff hour from last appt
... I $D(LAST) D
.... S X=$E($P(DATE,".",2),1,2)-$E(LAST,1,2) ;difference in hours
.... F I=1:1:X D SET("",.VALMCNT,BDGCNT,"") ;determines # of lines
... S LAST=ENDTM ;save end time to compare with next appt
... ;
... ; now print this appt
... D SET(LINE,.VALMCNT,BDGCNT,"OP"_U_(+DATA)_U_$P(DATA,U,5)_U_DATE)
... ; and other info comments
... D SET($$SP(17)_$E($P(DATA,U,4),1,50),.VALMCNT,BDGCNT,"")
... ;
... ; increment counter
... S BDGCNT=BDGCNT+1 ;number on display page
;
K ^TMP("BDGPV1",$J)
Q
;
Q
;
SCHVST ; find scheduled outpat visits and those for quarters
;D SCHED^BDGPV1("OUT")
Q
;
PRINT ; print report to paper
U IO D HDG
NEW LINE
S LINE=0 F S LINE=$O(^TMP("BDGPV",$J,LINE)) Q:'LINE D
. I $Y>(IOSL-4) D HDG
. W !,^TMP("BDGPV",$J,LINE,0)
D ^%ZISC,EXIT
Q
;
HDG ; heading for paper report
D HDR W @IOF,?30,"Provider's Current Inpatients"
NEW I F I=1:1 Q:'$D(VALMHDR(I)) W !,VALMHDR(I)
W !,$$REPEAT^XLFSTR("-",80)
W !?5,"Patient Name",?23,"Chart #",?33,"Wrd/Srv",?42,"Room-Bed"
W ?51,"Admit Date",?65,"Admitting Dx"
W !,$$REPEAT^XLFSTR("=",80)
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("BDGPV",$J) K BDGPRT
Q
;
EXPND ; -- expand code
Q
;
SET(LINE,LNUM,PNUM,IEN) ; puts display line into array
S LNUM=LNUM+1
S ^TMP("BDGPV",$J,LNUM,0)=LINE
S ^TMP("BDGPV",$J,"IDX",LNUM,PNUM)=IEN
Q
;
SRV() ; return current service abbreviation for patient
Q $$GET1^DIQ(45.7,+$G(^DPT(DFN,.103)),99)
;
WRD() ; return current ward abbreviation for patient
NEW X
S X=$G(^DPT(DFN,.1)) I X="" Q "??"
S X=$$GET1^DIQ(9009016.5,+$O(^DIC(42,"B",X,0)),.02)
Q $S(X="":"??",1:X)
;
PAD(D,L) ;EP -- SUBRTN to pad length of data
; -- D=data L=length
Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)
;
SP(N) ; -- SUBRTN to pad N number of spaces
Q $$PAD(" ",N)
BDGPV ; IHS/ANMC/LJF - PROVIDER INQUIRY ;
+1 ;;5.3;PIMS;;APR 26, 2002
+2 ;
+3 NEW BDGPV,BDGPVN,DEF,SCR,BDGSRT
+4 SET DEF=$SELECT($DATA(^XUSEC("PROVIDER",DUZ)):$$GET1^DIQ(200,DUZ,.01),1:"")
+5 ;screen for provider key
SET SCR="I $D(^XUSEC(""PROVIDER"",+Y))"
+6 SET BDGPV=$$READ^BDGF("PO^200:EMQZ","Select PROVIDER NAME",DEF,"",SCR)
+7 IF BDGPV<1
QUIT
SET BDGPVN=$PIECE(BDGPV,U,2)
SET BDGPV=+BDGPV
+8 ;
+9 SET BDGSRT=$$READ^BDGF("SAO^W:WARD;S:SERVICE","Inpatients sorted by Ward or Service: ","WARD")
IF BDGSRT=U
QUIT
+10 IF $$BROWSE^BDGF="B"
DO EN
QUIT
+11 DO ZIS^BDGF("PQ","START^BDGPV","PROVIDER'S INPATIENTS","BDGPV;BDGPVN;BDGSRT")
+12 QUIT
+13 ;
START ;EP; entry when printing to paper
+1 SET BDGPRT=1
DO INIT
DO PRINT
QUIT
+2 ;
EN ;EP; -- main entry point for BDG PROVIDER INQUIRY
+1 NEW VALMCNT
DO TERM^VALM0
DO CLEAR^VALM1
+2 DO EN^VALM("BDG PROVIDER INQUIRY")
+3 DO CLEAR^VALM1
+4 QUIT
+5 ;
HDR ; -- header code
+1 SET VALMHDR(1)=$$SP(10)_"** "_$$CONF^BDGF_" **"
+2 ;provider name
SET VALMHDR(2)=$$SP(75-$LENGTH(BDGPVN)\2)_BDGPVN
+3 SET VALMSG=$$SP(7)_"Attending/Admitting/Primary Care"
+4 QUIT
+5 ;
INIT ; -- init variables and list array
+1 IF '$GET(BDGPRT)
DO MSG^BDGF("Please wait while I compile the list...",1,0)
+2 NEW BDGCNT
+3 KILL ^TMP("BDGPV",$JOB),^TMP("BDGPV1",$JOB)
+4 ;line count
SET VALMCNT=0
+5 ;patient count for choosing patient entry
SET BDGCNT=1
+6 DO INPT
DO SCHADM
DO DAYSUR
DO SCHDS
DO APPTS
DO SCHVST
+7 IF '$DATA(^TMP("BDGPV",$JOB))
SET ^TMP("BDGPV",$JOB,1,0)="NO PATIENTS FOUND"
SET VALMCNT=1
+8 KILL ^TMP("BDGPV1",$JOB)
+9 QUIT
+10 ;
INPT ; find all inpatients for this provider
+1 NEW BDGCA,DFN,SRT,X,BDGX,LINE,CAT,SRT,NAME
+2 ; loop thru ACA xref in ^DPT for current admissions
+3 SET BDGCA=0
FOR
SET BDGCA=$ORDER(^DPT("ACA",BDGCA))
IF 'BDGCA
QUIT
Begin DoDot:1
+4 SET DFN=0
FOR
SET DFN=$ORDER(^DPT("ACA",BDGCA,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+5 ;
+6 ; set admissions into array sorted by category and ward/srv sort
+7 SET SRT=$SELECT(BDGSRT="W":$GET(^DPT(DFN,.1)),1:$$GET1^DIQ(2,DFN,.103))
+8 IF SRT=""
SET SRT="??"
+9 ;
+10 ; category 1: prov is prim inpt prov or attending
+11 IF $GET(^DPT(DFN,.1041))=BDGPV
Begin DoDot:3
+12 SET ^TMP("BDGPV1",$JOB,1,SRT,$$GET1^DIQ(2,DFN,.01),DFN)=BDGCA
End DoDot:3
QUIT
+13 ;
+14 ; category 2: prov is admitting only
+15 IF $$ADMPRV^BDGF1(BDGCA,DFN,"ADM")=BDGPVN
Begin DoDot:3
+16 SET ^TMP("BDGPV1",$JOB,2,SRT,$$GET1^DIQ(2,DFN,.01),DFN)=BDGCA
End DoDot:3
QUIT
+17 ;
+18 ; category 3: prov is PCP only
+19 KILL BDGX
SET BDGX="BDGX"
DO PCP^BSDU1(DFN,.BDGX)
+20 IF $PIECE(BDGX(1),"/",3)=BDGPV
Begin DoDot:3
+21 SET ^TMP("BDGPV1",$JOB,3,SRT,$$GET1^DIQ(2,DFN,.01),DFN)=BDGCA
End DoDot:3
End DoDot:2
End DoDot:1
+22 ;
+23 ; now take sorted list and put into display array
+24 SET CAT=0
FOR
SET CAT=$ORDER(^TMP("BDGPV1",$JOB,CAT))
IF 'CAT
QUIT
Begin DoDot:1
+25 ;
+26 ; put category subtitle into display array
+27 SET LINE=$SELECT(CAT=1:"Attending Provider:",CAT=2:"Admitting Provider:",1:"Primary Care Provider")
+28 DO SET($GET(IORVON)_LINE_$GET(IORVOFF),.VALMCNT,BDGCNT,"")
+29 ;
+30 SET SRT=0
FOR
SET SRT=$ORDER(^TMP("BDGPV1",$JOB,CAT,SRT))
IF SRT=""
QUIT
Begin DoDot:2
+31 ;
+32 ; put sort item subtitle into display array
+33 SET LINE="For "_SRT_$SELECT(BDGSRT="W":" Ward",1:" Service")
+34 DO SET($$SP(3)_$GET(IOUON)_LINE_$GET(IOUOFF),.VALMCNT,BDGCNT,"")
+35 ;
+36 SET NAME=0
FOR
SET NAME=$ORDER(^TMP("BDGPV1",$JOB,CAT,SRT,NAME))
IF NAME=""
DO SET("",.VALMCNT,BDGCNT,"")
IF NAME=""
QUIT
Begin DoDot:3
+37 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("BDGPV1",$JOB,CAT,SRT,NAME,DFN))
IF 'DFN
QUIT
Begin DoDot:4
+38 ;corresp adm ien
SET BDGCA=^TMP("BDGPV1",$JOB,CAT,SRT,NAME,DFN)
+39 ;
+40 ; build lines and put into display array
+41 SET LINE=$JUSTIFY(BDGCNT,2)_") "_$EXTRACT(NAME,1,18)
+42 SET LINE=$$PAD(LINE,24)_$JUSTIFY($$HRCN^BDGF2(DFN,DUZ(2)),6)
+43 ;wrd/srv
SET LINE=$$PAD(LINE,33)_$SELECT(BDGSRT="W":$$SRV,1:$$WRD)
+44 ;room-bed
SET LINE=$$PAD(LINE,41)_$GET(^DPT(DFN,.101))
+45 ;admit dt
SET LINE=$$PAD(LINE,50)_$PIECE($$GET1^DIQ(405,BDGCA,.01),"@")
+46 ;dx
SET LINE=$$PAD(LINE,64)_$$GET1^DIQ(405,BDGCA,.1)
+47 DO SET(LINE,.VALMCNT,BDGCNT,"IP"_U_DFN_U_BDGCA)
+48 ;
+49 ;cwad
SET LINE=$$PAD($$SP(5)_$$CWAD^BDGF2(DFN),17)
+50 ;attend
SET LINE=LINE_$EXTRACT($$GET1^DIQ(2,DFN,.1041),1,15)_"/"
+51 ;admtg
SET LINE=LINE_$EXTRACT($$ADMPRV^BDGF1(BDGCA,DFN,"ADM"),1,15)_"/"
+52 KILL BDGX
SET BDGX="BDGX"
DO PCP^BSDU1(DFN,.BDGX)
+53 ;pcp
SET LINE=LINE_$EXTRACT($PIECE($GET(BDGX(1)),"/"),1,15)
+54 DO SET(LINE,.VALMCNT,BDGCNT,"IP"_U_DFN_U_BDGCA)
+55 ;
+56 ; increment patient selection number
+57 SET BDGCNT=BDGCNT+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+58 QUIT
+59 ;
SCHADM ; find scheduled admissions for next week for provider
+1 ;D SCHED^BDGPV1("IP")
+2 QUIT
+3 ;
DAYSUR ; find all day surgery patients for this provider
+1 IF $TEXT(PRVSUR^BSRPEP)]""
Begin DoDot:1
+2 NEW BDGRR,X,DATE,IEN,BDGI
+3 KILL ^TMP("BDGPV1",$JOB)
+4 SET BDGRR="^TMP(""BDGPV1"",$J)"
+5 ;get list from surgery
DO PRVSUR^BSRPEP(BDGPV,DT,.BDGRR)
+6 IF '$DATA(^TMP("BDGPV1",$JOB))
QUIT
+7 ;
+8 DO SET("Today's Surgeries:",.VALMCNT,BDGCNT,"")
+9 ;
+10 IF $DATA(^TMP("BDGPV1",$JOB))
Begin DoDot:2
+11 SET DATE=0
FOR
SET DATE=$ORDER(^TMP("BDGPV1",$JOB,DATE))
IF 'DATE
QUIT
Begin DoDot:3
+12 SET IEN=0
FOR
SET IEN=$ORDER(^TMP("BDGPV1",$JOB,DATE,IEN))
IF 'IEN
QUIT
Begin DoDot:4
+13 FOR BDGI=1:1
IF '$DATA(^TMP("BDGPV1",$JOB,DATE,IEN,BDGI))
QUIT
Begin DoDot:5
+14 SET X=$SELECT(BDGI=1:$JUSTIFY(BDGCNT,2)_") ",1:$$SP(4))
+15 SET X=X_^TMP("BDGPV1",$JOB,DATE,IEN,BDGI)
+16 DO SET(X,.VALMCNT,BDGCNT,"SR"_U_IEN)
End DoDot:5
+17 SET BDGCNT=BDGCNT+1
End DoDot:4
End DoDot:3
End DoDot:2
+18 KILL ^TMP("BDGPV1",$JOB)
End DoDot:1
QUIT
+19 ;
+20 ;
+21 ; look for day surgeries scheduled for today
+22 NEW BDGDT,BDGEND,DFN,IENS,LINE,BDGFRST
+23 SET BDGDT=DT-.0001
SET BDGEND=DT+.24
SET BDGFRST=1
+24 FOR
SET BDGDT=$ORDER(^ADGDS("AA",BDGDT))
IF 'BDGDT
QUIT
IF BDGDT>BDGEND
QUIT
Begin DoDot:1
+25 SET DFN=0
FOR
SET DFN=$ORDER(^ADGDS("AA",BDGDT,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+26 SET BDGDS=0
FOR
SET BDGDS=$ORDER(^ADGDS("AA",BDGDT,DFN,BDGDS))
IF 'BDGDS
QUIT
Begin DoDot:3
+27 ;
+28 ; if first on list, display subheading
+29 IF BDGFRST
DO SET($GET(IORVON)_"Today's Day Surgeries:"_$GET(IORVOFF),.VALMCNT,BDGCNT,"")
SET BDGFRST=0
+30 ;
+31 ; put today's surgeries into display array
+32 SET IENS=DFN_","_BDGDS
+33 SET LINE=$JUSTIFY(BDGCNT,2)_") "_$PIECE($$GET1^DIQ(9009012.01,IENS,.01),".",2)
+34 ;pat name
SET LINE=$$PAD(LINE,12)_$EXTRACT($$GET1^DIQ(2,DFN,.01),1,18)
+35 ;chart #
SET LINE=$$PAD(LINE,32)_$JUSTIFY($$HRCN^BDGF2(DFN,DUZ(2)),6)
+36 ;procedure
SET LINE=$$PAD(LINE,40)_$$GET1^DIQ(9009012.01,IENS,1)
+37 DO SET(LINE,.VALMCNT,BDGCNT,"DS"_U_DFN_U_BDGDS)
+38 ;
+39 ; build status line with released date/time or other status
+40 SET STATUS=""
SET X=$$GET1^DIQ(9009012.01,IENS,7)
IF X]""
Begin DoDot:4
+41 SET STATUS="Released at "_X
+42 IF $$GET1^DIQ(9009012.01,IENS,11)="YES"
SET STATUS=STATUS_" (Admitted)"
QUIT
+43 IF $$GET1^DIQ(9009012.01,IENS,15)="YES"
SET STATUS=STATUS_" (Unescorted)"
End DoDot:4
+44 ;
+45 IF STATUS=""
Begin DoDot:4
+46 IF $$GET1^DIQ(9009012.01,IENS,12)="YES"
SET STATUS="**CANCELLED**"
QUIT
+47 IF $$GET1^DIQ(9009012.01,IENS,13)="YES"
SET STATUS="**NO-SHOW**"
QUIT
End DoDot:4
+48 ;
+49 DO SET($$SP(10)_STATUS,.VALMCNT,BDGCNT,"DS"_U_DFN_U_BDGDS)
+50 ;
+51 ; increment counter
+52 SET BDGCNT=BDGCNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+53 QUIT
+54 ;
SCHDS ; find scheduled day surgeries
+1 ;D SCHED^BDGPV1("DS")
+2 QUIT
+3 ;
APPTS ; find all appts for provider for today
+1 NEW BSDPRV,BSDQUIET,BSDDT
+2 SET BSDPRV=BDGPV
SET BSDDT=DT
SET BSDQUIET=1
+3 ;sets ^TMP("BSDPV2",$J) array
DO CLINICS^BSDPVD
+4 ;
+5 ; next lines of code were copied from BSDPVD and modified to fit this
+6 ; display array with the proper selelction numbers
+7 KILL ^TMP("BDGPV1",$JOB)
+8 ;
+9 ; loop thru provider's clinics and then appts for date
+10 NEW CLN,CLNM,IEN,DATE,END,NODE
+11 SET CLN=0
FOR
SET CLN=$ORDER(^TMP("BSDPVD2",$JOB,CLN))
IF 'CLN
QUIT
Begin DoDot:1
+12 ;clinic abbrievation
SET CLNM=$$GET1^DIQ(44,CLN,1)
+13 ;
+14 SET DATE=BSDDT-.0001
SET END=BSDDT_".2400"
+15 FOR
SET DATE=$ORDER(^SC(CLN,"S",DATE))
IF 'DATE
QUIT
IF (DATE>END)
QUIT
Begin DoDot:2
+16 SET IEN=0
FOR
SET IEN=$ORDER(^SC(CLN,"S",DATE,1,IEN))
IF 'IEN
QUIT
Begin DoDot:3
+17 ;
+18 ; sort by date,clinic; save clinic ien, patient, length, info
+19 SET NODE=$GET(^SC(CLN,"S",DATE,1,IEN,0))
IF 'NODE
QUIT
+20 SET ^TMP("BDGPV1",$JOB,DATE,CLNM,IEN)=$PIECE(NODE,U,1,4)_U_CLN_U_$GET(^SC(CLN,"S",DATE,1,IEN,"OB"))
End DoDot:3
End DoDot:2
End DoDot:1
+21 ;
+22 IF '$DATA(^TMP("BDGPV1",$JOB))
QUIT
+23 DO SET($GET(IORVON)_"Today's Appointments:"_$GET(IORVOFF),.VALMCNT,BDGCNT,"")
+24 DO SET($$SP(4)_$GET(IOUON)_"Appt Time Clinic Patient"_$GET(IOUOFF),.VALMCNT,BDGCNT,"")
+25 ;
+26 ; put sorted list into display array
+27 NEW DATE,CLN,IEN,DATA,LINE,X,I,LAST,ENDTM
+28 SET DATE=0
FOR
SET DATE=$ORDER(^TMP("BDGPV1",$JOB,DATE))
IF 'DATE
QUIT
Begin DoDot:1
+29 SET CLN=0
FOR
SET CLN=$ORDER(^TMP("BDGPV1",$JOB,DATE,CLN))
IF CLN=""
QUIT
Begin DoDot:2
+30 SET IEN=0
FOR
SET IEN=$ORDER(^TMP("BDGPV1",$JOB,DATE,CLN,IEN))
IF 'IEN
QUIT
Begin DoDot:3
+31 SET DATA=^TMP("BDGPV1",$JOB,DATE,CLN,IEN)
+32 ;appt time
SET LINE=$JUSTIFY(BDGCNT,2)_") "_$PIECE($$FMTE^XLFDT(DATE,2),"@",2)
+33 SET ENDTM=$PIECE($$FMTE^XLFDT($$FMADD^XLFDT(DATE,0,0,$PIECE(DATA,U,2))),"@",2)
+34 ;end time/overbk
SET LINE=LINE_"-"_ENDTM_$TRANSLATE($PIECE(DATA,U,6),"O","*")
+35 ;end time & clinic
SET LINE=$$PAD(LINE,17)_CLN
+36 ;patient
SET LINE=$$PAD(LINE,26)_$EXTRACT($$GET1^DIQ(2,+DATA,.01),1,18)
+37 ;chart #
SET LINE=$$PAD(LINE,45)_$JUSTIFY("#"_$$HRCN^BDGF2(+DATA,DUZ(2)),6)
+38 ;cwad
SET LINE=$$PAD(LINE,54)_$$CWAD^BDGF2(+DATA)
+39 ;
+40 ; add extra lines if end time diff hour from last appt
+41 IF $DATA(LAST)
Begin DoDot:4
+42 ;difference in hours
SET X=$EXTRACT($PIECE(DATE,".",2),1,2)-$EXTRACT(LAST,1,2)
+43 ;determines # of lines
FOR I=1:1:X
DO SET("",.VALMCNT,BDGCNT,"")
End DoDot:4
+44 ;save end time to compare with next appt
SET LAST=ENDTM
+45 ;
+46 ; now print this appt
+47 DO SET(LINE,.VALMCNT,BDGCNT,"OP"_U_(+DATA)_U_$PIECE(DATA,U,5)_U_DATE)
+48 ; and other info comments
+49 DO SET($$SP(17)_$EXTRACT($PIECE(DATA,U,4),1,50),.VALMCNT,BDGCNT,"")
+50 ;
+51 ; increment counter
+52 ;number on display page
SET BDGCNT=BDGCNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+53 ;
+54 KILL ^TMP("BDGPV1",$JOB)
+55 QUIT
+56 ;
+57 QUIT
+58 ;
SCHVST ; find scheduled outpat visits and those for quarters
+1 ;D SCHED^BDGPV1("OUT")
+2 QUIT
+3 ;
PRINT ; print report to paper
+1 USE IO
DO HDG
+2 NEW LINE
+3 SET LINE=0
FOR
SET LINE=$ORDER(^TMP("BDGPV",$JOB,LINE))
IF 'LINE
QUIT
Begin DoDot:1
+4 IF $Y>(IOSL-4)
DO HDG
+5 WRITE !,^TMP("BDGPV",$JOB,LINE,0)
End DoDot:1
+6 DO ^%ZISC
DO EXIT
+7 QUIT
+8 ;
HDG ; heading for paper report
+1 DO HDR
WRITE @IOF,?30,"Provider's Current Inpatients"
+2 NEW I
FOR I=1:1
IF '$DATA(VALMHDR(I))
QUIT
WRITE !,VALMHDR(I)
+3 WRITE !,$$REPEAT^XLFSTR("-",80)
+4 WRITE !?5,"Patient Name",?23,"Chart #",?33,"Wrd/Srv",?42,"Room-Bed"
+5 WRITE ?51,"Admit Date",?65,"Admitting Dx"
+6 WRITE !,$$REPEAT^XLFSTR("=",80)
+7 QUIT
+8 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("BDGPV",$JOB)
KILL BDGPRT
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
SET(LINE,LNUM,PNUM,IEN) ; puts display line into array
+1 SET LNUM=LNUM+1
+2 SET ^TMP("BDGPV",$JOB,LNUM,0)=LINE
+3 SET ^TMP("BDGPV",$JOB,"IDX",LNUM,PNUM)=IEN
+4 QUIT
+5 ;
SRV() ; return current service abbreviation for patient
+1 QUIT $$GET1^DIQ(45.7,+$GET(^DPT(DFN,.103)),99)
+2 ;
WRD() ; return current ward abbreviation for patient
+1 NEW X
+2 SET X=$GET(^DPT(DFN,.1))
IF X=""
QUIT "??"
+3 SET X=$$GET1^DIQ(9009016.5,+$ORDER(^DIC(42,"B",X,0)),.02)
+4 QUIT $SELECT(X="":"??",1:X)
+5 ;
PAD(D,L) ;EP -- SUBRTN to pad length of data
+1 ; -- D=data L=length
+2 QUIT $EXTRACT(D_$$REPEAT^XLFSTR(" ",L),1,L)
+3 ;
SP(N) ; -- SUBRTN to pad N number of spaces
+1 QUIT $$PAD(" ",N)
