BTIUDSC ; IHS/ITSC/LJF - DICTATION COUNTS ;15-Jul-2013 09:58;DU
;;1.0;TEXT INTEGRATION UTILITIES;**1011**;NOV 04, 2004;Build 13
;
;
D ^XBCLS
S Y=$$READ^TIUU("SO^1:DISCHARGE SUMMARY DICTATIONS;2:OPERATIVE REPORT DICTATIONS","Select REPORT TYPE") Q:'Y
I +Y=2 D ^BTIUDOC Q
;
NEW TIUEDT,TIUBDT
S TIUBDT=$$EDATE^TIULA("Discharge",""," ") Q:TIUBDT<1
S TIUEDT=$$LDATE^TIULA("Discharge",""," ") Q:TIUEDT<1
D ZIS^BTIUU("PQ","EN^BTIUDSC","DSUM DICT COUNTS","TIUBDT;TIUEDT")
Q
;
EN ; -- main entry point for BTIU DSUM COUNTS
NEW VALMCNT
I IOST'["C-" D GATHER(TIUBDT,TIUEDT),PRINT Q
D TERM^VALM0
D EN^VALM("BTIU IC DICT STATUS")
Q
;
HDR ;EP; -- header code
Q
;
INIT ;EP; -- init variables and list array
NEW TIULN
D MSG^BTIUU("Building/Updating Display. . .Please wait.",2,0,0)
D GATHER(TIUBDT,TIUEDT)
S VALMCNT=TIULN
Q
;
INIT2 ;EP; -- init variables and list array
NEW TIULN
S VALMCNT=+$O(^TMP("BTIUDSC",$J,""),-1)
Q
;
HELP ;EP; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ;EP; -- exit code
K VALMCNT
K ^TMP("BTIUDSC",$J),^TMP("BTIUDSC2",$J)
Q
;
EXIT2 ;EP; -- exit code for patient listing
K VALMCNT Q
;
EXPND ; -- expand code
Q
;
GATHER(TIUBDT,TIUEDT) ; -- create display array
NEW X,TIUCNT,TIUCD,DFN,DSC,IEN,CD,DSCH,LINE,TIUN,TIUSRV,D,N,X,P,DDATE,DAYS,END,I,S
K ^TMP("BTIUDSC",$J),^TMP("BTIUDSC1",$J),^TMP("BTIUDSC2",$J)
K ^TMP("BTIUDSC3",$J)
S (TIUCNT,TIULN)=0
S DDATE=TIUBDT-.0001,END=TIUEDT+.2400
F S DDATE=$O(^DGPM("ATT3",DDATE)) Q:'DDATE!(DDATE>END) D
. S IEN=0 F S IEN=$O(^DGPM("ATT3",DDATE,IEN)) Q:'IEN D
.. S DFN=$P(^DGPM(IEN,0),U,3),TIUCA=$P(^DGPM(IEN,0),U,14)
.. S TIUDSDT=+^DGPM(IEN,0),TIUADDT=+^DGPM(TIUCA,0)
.. Q:TIUDSDT=""
.. S TIUVST=$$GET1^DIQ(405,TIUCA,.27,"I") I TIUVST<1 D ERR(1) Q
.. S TIUSRV=$$DSRV(TIUCA) Q:TIUSRV["OBSERVATION"
.. Q:TIUSRV=""
.. S DAYS=$S(TIUSRV="NEWBORN":5,1:3) ;anmc parameter for req dis summ
.. I $$FMDIFF^XLFDT(TIUDSDT,TIUADDT,1)<DAYS Q ;LOS<3 or 4 or 5 days
.. ;
.. NEW TIUDICT,TIUAUTH
.. S TIU=0,TIUAUTH="",TIUDICT=""
.. F S TIU=$O(^TIU(8925,"V",TIUVST,TIU)) Q:'TIU!($G(TIUDICT)) D
... I '$$CLASS(+$G(^TIU(8925,TIU,0))) Q ;not dsum
... S TIUDICT=$$GET1^DIQ(8925,TIU,1307,"I") ;dictation date
... S TIUAUTH=$$GET1^DIQ(8925,TIU,1202) ;dictated by
.. S LINE=$$DATA(DFN,TIUDSDT,$G(TIUDICT)) ;create display line
.. I LINE'="" S ^TMP("BTIUDSC3",$J,TIUSRV,TIUDSDT,IEN)=LINE
.. D TOT(TIUSRV,$$DPRV(TIUCA,TIUAUTH),TIUDSDT,TIUDICT)
;
; -- put listing in order by service and dsch date
S TIULN=0,S=0 F S S=$O(^TMP("BTIUDSC3",$J,S)) Q:S="" D
. D SET("",.TIULN),SET("SERVICE: "_S,.TIULN)
. S D=0 F S D=$O(^TMP("BTIUDSC3",$J,S,D)) Q:D="" D
.. S N=0 F S N=$O(^TMP("BTIUDSC3",$J,S,D,N)) Q:'N D
... S X=^TMP("BTIUDSC3",$J,S,D,N) D SET(X,.TIULN)
;
; -- put totals in order by service and provider
NEW TOTAL S TOTAL=0
S TIULN=0,S=0 F S S=$O(^TMP("BTIUDSC1",$J,S)) Q:S="" D
. S X=^TMP("BTIUDSC1",$J,S),LINE=$$LINE2(S,"",X)
. D TOTL(X,.TOTAL) ;increment grand total
. D SET2("",.TIULN),SET2(LINE,.TIULN)
. S P=0 F S P=$O(^TMP("BTIUDSC1",$J,S,P)) Q:P="" D
.. S X=^TMP("BTIUDSC1",$J,S,P),LINE=$$LINE2("",P,X) D SET2(LINE,.TIULN)
;
S LINE=$$REPEAT^XLFSTR("=",79) D SET2("",.TIULN),SET2(LINE,.TIULN)
S LINE=$$LINE2("GRAND TOTAL","",TOTAL) D SET2(LINE,.TIULN)
S LINE=$$LINE3(TOTAL) D SET2(LINE,.TIULN),SET2("",.TIULN)
K ^TMP("BTIUDSC1",$J),^TMP("BTIUDSC3",$J)
Q
;
;
DATA(DFN,DSDT,DICT) ; -- returns display line
NEW X,TIUY
;S TIUCNT=TIUCNT+1,TIUY=$J(TIUCNT,3)
S TIUY=$$PAD($$PAT(DFN),27)_" "
S TIUY=TIUY_$$PAD($$DPRV(TIUCA,TIUAUTH),15)
S TIUY=TIUY_$$PAD($J($$FMTE^XLFDT(DSDT,"2D"),10),12)
S TIUY=TIUY_$$PAD($J($$FMTE^XLFDT(DICT,"2"),10),13)
S TIUY=TIUY_$$STATUS(DICT\1,DSDT)
Q TIUY
;
PAT(DFN) ; -- returns patient chart # and last name
NEW X,Y
S X=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
S Y=$P($G(^DPT(DFN,0)),U)
Q $J(X,7)_" "_$E(Y,1,18)
;
STATUS(DICT,DSCH) ; -- returns whether dictated on time or not
I +DICT=0 Q "NOT DONE"
I DICT'>DSCH Q "ON TIME"
Q "LATE"
;
CLASS(TYPE) ; -- returns 1 if doc is in dsch summ dic class (244)
I $$GET1^DIQ(8925.1,TYPE,.01)="ADDENDUM" S TYPE=$$GET1^DIQ(8925,IEN,.04,"I")
I $$DOCCLASS^TIULC1(TYPE)=244 Q 1
Q 0
;
DSRV(CA) ; -- discharge service
I $L($T(^BDGF1)) Q $$LASTSRVN^BDGF1(CA,DFN) ;PIMS V5.3
NEW X,Y
S Y=9999999.9999999-$G(^DGPM(+$P(^DGPM(CA,0),U,17),0)) Q:'Y 0
S X=$O(^DGPM("ATID6",+DFN,+$O(^DGPM("ATID6",+DFN,Y)),0))
S X=$P($G(^DGPM(+X,0)),U,9)
Q $$GET1^DIQ(45.7,X,.01)
;
DPRV(CA,AUTH) ; -- discharge provider
I AUTH]"" Q AUTH
I $L($T(^BDGF1)) Q $$LASTPRV^BDGF1(CA,DFN,"") ;PIMS V5.3
NEW W,X,Y,Z,AP
S X="",Y=0 F S Y=$O(^DGPM("ATS",DFN,TIUCA,Y)) Q:'Y!(X]"") D
. S Z=0 F S Z=$O(^DGPM("ATS",DFN,TIUCA,Y,Z)) Q:'Z!(X]"") D
.. S W=0 F S W=$O(^DGPM("ATS",DFN,TIUCA,Y,Z,W)) Q:'W!(X]"") D
... S X=$$GET1^DIQ(405,W,.19) ;attending
... I X="" S AP=$$GET1^DIQ(405,W,.08) ;admitting
I X="" S X=$S($G(AP)]"":AP,1:"??")
Q X
;
;
SET(LINE,TIULN) ; -- sets ^tmp
S TIULN=TIULN+1
S ^TMP("BTIUDSC",$J,TIULN,0)=LINE
Q
;
SET2(LINE,TIULN) ; -- sets ^tmp
S TIULN=TIULN+1
S ^TMP("BTIUDSC2",$J,TIULN,0)=LINE
Q
;
PRINT ; -- print lists to paper
NEW TIUX,TIUL,TIUPG
U IO D INIT^BTIUU
F TIUX="BTIUDSC2","BTIUDSC" D
. D HDG
. S TIUL=0 F S TIUL=$O(^TMP(TIUX,$J,TIUL)) Q:'TIUL D
.. I $Y>(IOSL-4) D HDG
.. W !,^TMP(TIUX,$J,TIUL,0)
D ^%ZISC,PRTKL^BTIUU,EXIT
Q
;
HDG ; -- prints 2nd half of heading
S TIUPG=$G(TIUPG)+1 I TIUPG>1 W @IOF
W !,TIUTIME,?16,$$CONFID^BTIUU,?71,"Page: ",TIUPG
W !,TIUDATE,?24,"DISCHARGE SUMMARY DICTATION STATISTICS",?76,TIUUSR
W !?($L(TIUFAC\2)),TIUFAC,!,$$REPEAT^XLFSTR("-",80)
;
I TIUX="BTIUDSC2" S X=" Service"_$$SP(13)_"Provider"_$$SP(12)_"#DSCH Dict: On Time Late Not Done"
E S X=" HRCN Patient Name"_$$SP(8)_"Provider"_$$SP(5)_"Dschargd Dictated Status"
W !,X,!,$$REPEAT^XLFSTR("=",80)
Q
;
TOT(SRV,PRV,DSC,DICT) ; -- increment ^tmp for totals
NEW X,Y
S X=$G(^TMP("BTIUDSC1",$J,SRV,PRV)),Y=$G(^TMP("BTIUDSC1",$J,SRV))
D INCREM
S ^TMP("BTIUDSC1",$J,SRV)=Y,^TMP("BTIUDSC1",$J,SRV,PRV)=X
Q
;
TOTL(DATA,TOTAL) ; increment grand total
F I=1:1:4 S $P(TOTAL,U,I)=$P(TOTAL,U,I)+$P(DATA,U,I)
Q
;
INCREM ; -- increment # discharges,dictated on time, late or not at all
S $P(X,U)=$P(X,U)+1,$P(Y,U)=$P(Y,U)+1 ;total dsch
I DICT="" S $P(X,U,4)=$P(X,U,4)+1,$P(Y,U,4)=$P(Y,U,4)+1 Q ;not dict
I DICT'>DSC S $P(X,U,2)=$P(X,U,2)+1,$P(Y,U,2)=$P(Y,U,2)+1 Q ;on time
S $P(X,U,3)=$P(X,U,3)+1,$P(Y,U,3)=$P(Y,U,3)+1 ;dict late
Q
;
LINE2(SRV,PRV,DATA) ; -- sets up display line for totals
NEW X
S X=" "_$$PAD(SRV,18)_" "_$$PAD($E(PRV,1,18),21)
S X=X_$$PAD($J($P(DATA,U),3),15)_$$PAD($J($P(DATA,U,2),3),7)
S X=X_$$PAD($J($P(DATA,U,3),3),7)_$J($P(DATA,U,4),3)
Q X
;
LINE3(DATA) ; -- sets up display line for totals
NEW X,T,OT,LT,ND
S T=$P(DATA,U) I 'T S (OT,LT,ND)=0
E S OT=$P(DATA,U,2)/T*100,LT=$P(DATA,U,3)/T*100,ND=$P(DATA,U,4)/T*100
S X=$$SP(57)_$$PAD($J(OT,3,0)_"%",7)
S X=X_$$PAD($J(LT,3,0)_"%",7)_$J(ND,3,0)_"%"
Q X
;
GETIC ; -- select item from list
NEW X,Y,Z,VALMY
D FULL^VALM1
S TIUICN=0
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) Q
S X=$O(VALMY(0))
S Y=0 F S Y=$O(^TMP("TIUZICL",$J,"IDX",Y)) Q:Y="" Q:TIUICN>0 D
. S Z=$O(^TMP("TIUZICL",$J,"IDX",Y,0))
. Q:^TMP("TIUZICL",$J,"IDX",Y,Z)=""
. I Z=X S TIUICN=^TMP("TIUZICL",$J,"IDX",Y,Z)
Q
;
ICE ;EP; -- action to edit IC file
NEW TIUICN,DIE,DA,DR
D GETIC I 'TIUICN D RESET2 Q
S DIE="^BDGIC(",DA=+TIUICN,DR="[BTIU ICE UPDATE]" D ^DIE
Q
;
ICP ;EP; -- action to print chart copy
NEW TIUICN
D GETIC Q:'TIUICN S TIUDA=$P(TIUICN,U,2) I TIUDA="" Q
D PRINT1^TIURA
Q
;
RESET ;EP; -- action to rebuild display
D TERM^VALM0 S VALMBCK="R"
D INIT,HDR Q
;
RESET2 ;EP; -- action to rebuild display
D TERM^VALM0 S VALMBCK="R"
D HDR S VALMCNT=$O(^TMP("BTIUDSC2",$J,""),-1) Q
;
PAD(DATA,LENGTH) ; -- SUBRTN to pad length of data
Q $E(DATA_$$REPEAT^XLFSTR(" ",LENGTH),1,LENGTH)
;
SP(NUM) ; -- SUBRTN to pad spaces
Q $$PAD(" ",NUM)
;
PROV() ; -- ask for provider
Q $$READ^TIUU("PO^200","Select PROVIDER NAME")
;
ERR(NUM) ; -- sets errors
S LINE="ERROR MESSAGE: DFN="_DFN_" TIUCA="_TIUCA_" NO VISIT"
D SET(LINE,.TIULN)
Q
BTIUDSC ; IHS/ITSC/LJF - DICTATION COUNTS ;15-Jul-2013 09:58;DU
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**1011**;NOV 04, 2004;Build 13
+2 ;
+3 ;
+4 DO ^XBCLS
+5 SET Y=$$READ^TIUU("SO^1:DISCHARGE SUMMARY DICTATIONS;2:OPERATIVE REPORT DICTATIONS","Select REPORT TYPE")
IF 'Y
QUIT
+6 IF +Y=2
DO ^BTIUDOC
QUIT
+7 ;
+8 NEW TIUEDT,TIUBDT
+9 SET TIUBDT=$$EDATE^TIULA("Discharge",""," ")
IF TIUBDT<1
QUIT
+10 SET TIUEDT=$$LDATE^TIULA("Discharge",""," ")
IF TIUEDT<1
QUIT
+11 DO ZIS^BTIUU("PQ","EN^BTIUDSC","DSUM DICT COUNTS","TIUBDT;TIUEDT")
+12 QUIT
+13 ;
EN ; -- main entry point for BTIU DSUM COUNTS
+1 NEW VALMCNT
+2 IF IOST'["C-"
DO GATHER(TIUBDT,TIUEDT)
DO PRINT
QUIT
+3 DO TERM^VALM0
+4 DO EN^VALM("BTIU IC DICT STATUS")
+5 QUIT
+6 ;
HDR ;EP; -- header code
+1 QUIT
+2 ;
INIT ;EP; -- init variables and list array
+1 NEW TIULN
+2 DO MSG^BTIUU("Building/Updating Display. . .Please wait.",2,0,0)
+3 DO GATHER(TIUBDT,TIUEDT)
+4 SET VALMCNT=TIULN
+5 QUIT
+6 ;
INIT2 ;EP; -- init variables and list array
+1 NEW TIULN
+2 SET VALMCNT=+$ORDER(^TMP("BTIUDSC",$JOB,""),-1)
+3 QUIT
+4 ;
HELP ;EP; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ;EP; -- exit code
+1 KILL VALMCNT
+2 KILL ^TMP("BTIUDSC",$JOB),^TMP("BTIUDSC2",$JOB)
+3 QUIT
+4 ;
EXIT2 ;EP; -- exit code for patient listing
+1 KILL VALMCNT
QUIT
+2 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
GATHER(TIUBDT,TIUEDT) ; -- create display array
+1 NEW X,TIUCNT,TIUCD,DFN,DSC,IEN,CD,DSCH,LINE,TIUN,TIUSRV,D,N,X,P,DDATE,DAYS,END,I,S
+2 KILL ^TMP("BTIUDSC",$JOB),^TMP("BTIUDSC1",$JOB),^TMP("BTIUDSC2",$JOB)
+3 KILL ^TMP("BTIUDSC3",$JOB)
+4 SET (TIUCNT,TIULN)=0
+5 SET DDATE=TIUBDT-.0001
SET END=TIUEDT+.2400
+6 FOR
SET DDATE=$ORDER(^DGPM("ATT3",DDATE))
IF 'DDATE!(DDATE>END)
QUIT
Begin DoDot:1
+7 SET IEN=0
FOR
SET IEN=$ORDER(^DGPM("ATT3",DDATE,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+8 SET DFN=$PIECE(^DGPM(IEN,0),U,3)
SET TIUCA=$PIECE(^DGPM(IEN,0),U,14)
+9 SET TIUDSDT=+^DGPM(IEN,0)
SET TIUADDT=+^DGPM(TIUCA,0)
+10 IF TIUDSDT=""
QUIT
+11 SET TIUVST=$$GET1^DIQ(405,TIUCA,.27,"I")
IF TIUVST<1
DO ERR(1)
QUIT
+12 SET TIUSRV=$$DSRV(TIUCA)
IF TIUSRV["OBSERVATION"
QUIT
+13 IF TIUSRV=""
QUIT
+14 ;anmc parameter for req dis summ
SET DAYS=$SELECT(TIUSRV="NEWBORN":5,1:3)
+15 ;LOS<3 or 4 or 5 days
IF $$FMDIFF^XLFDT(TIUDSDT,TIUADDT,1)<DAYS
QUIT
+16 ;
+17 NEW TIUDICT,TIUAUTH
+18 SET TIU=0
SET TIUAUTH=""
SET TIUDICT=""
+19 FOR
SET TIU=$ORDER(^TIU(8925,"V",TIUVST,TIU))
IF 'TIU!($GET(TIUDICT))
QUIT
Begin DoDot:3
+20 ;not dsum
IF '$$CLASS(+$GET(^TIU(8925,TIU,0)))
QUIT
+21 ;dictation date
SET TIUDICT=$$GET1^DIQ(8925,TIU,1307,"I")
+22 ;dictated by
SET TIUAUTH=$$GET1^DIQ(8925,TIU,1202)
End DoDot:3
+23 ;create display line
SET LINE=$$DATA(DFN,TIUDSDT,$GET(TIUDICT))
+24 IF LINE'=""
SET ^TMP("BTIUDSC3",$JOB,TIUSRV,TIUDSDT,IEN)=LINE
+25 DO TOT(TIUSRV,$$DPRV(TIUCA,TIUAUTH),TIUDSDT,TIUDICT)
End DoDot:2
End DoDot:1
+26 ;
+27 ; -- put listing in order by service and dsch date
+28 SET TIULN=0
SET S=0
FOR
SET S=$ORDER(^TMP("BTIUDSC3",$JOB,S))
IF S=""
QUIT
Begin DoDot:1
+29 DO SET("",.TIULN)
DO SET("SERVICE: "_S,.TIULN)
+30 SET D=0
FOR
SET D=$ORDER(^TMP("BTIUDSC3",$JOB,S,D))
IF D=""
QUIT
Begin DoDot:2
+31 SET N=0
FOR
SET N=$ORDER(^TMP("BTIUDSC3",$JOB,S,D,N))
IF 'N
QUIT
Begin DoDot:3
+32 SET X=^TMP("BTIUDSC3",$JOB,S,D,N)
DO SET(X,.TIULN)
End DoDot:3
End DoDot:2
End DoDot:1
+33 ;
+34 ; -- put totals in order by service and provider
+35 NEW TOTAL
SET TOTAL=0
+36 SET TIULN=0
SET S=0
FOR
SET S=$ORDER(^TMP("BTIUDSC1",$JOB,S))
IF S=""
QUIT
Begin DoDot:1
+37 SET X=^TMP("BTIUDSC1",$JOB,S)
SET LINE=$$LINE2(S,"",X)
+38 ;increment grand total
DO TOTL(X,.TOTAL)
+39 DO SET2("",.TIULN)
DO SET2(LINE,.TIULN)
+40 SET P=0
FOR
SET P=$ORDER(^TMP("BTIUDSC1",$JOB,S,P))
IF P=""
QUIT
Begin DoDot:2
+41 SET X=^TMP("BTIUDSC1",$JOB,S,P)
SET LINE=$$LINE2("",P,X)
DO SET2(LINE,.TIULN)
End DoDot:2
End DoDot:1
+42 ;
+43 SET LINE=$$REPEAT^XLFSTR("=",79)
DO SET2("",.TIULN)
DO SET2(LINE,.TIULN)
+44 SET LINE=$$LINE2("GRAND TOTAL","",TOTAL)
DO SET2(LINE,.TIULN)
+45 SET LINE=$$LINE3(TOTAL)
DO SET2(LINE,.TIULN)
DO SET2("",.TIULN)
+46 KILL ^TMP("BTIUDSC1",$JOB),^TMP("BTIUDSC3",$JOB)
+47 QUIT
+48 ;
+49 ;
DATA(DFN,DSDT,DICT) ; -- returns display line
+1 NEW X,TIUY
+2 ;S TIUCNT=TIUCNT+1,TIUY=$J(TIUCNT,3)
+3 SET TIUY=$$PAD($$PAT(DFN),27)_" "
+4 SET TIUY=TIUY_$$PAD($$DPRV(TIUCA,TIUAUTH),15)
+5 SET TIUY=TIUY_$$PAD($JUSTIFY($$FMTE^XLFDT(DSDT,"2D"),10),12)
+6 SET TIUY=TIUY_$$PAD($JUSTIFY($$FMTE^XLFDT(DICT,"2"),10),13)
+7 SET TIUY=TIUY_$$STATUS(DICT\1,DSDT)
+8 QUIT TIUY
+9 ;
PAT(DFN) ; -- returns patient chart # and last name
+1 NEW X,Y
+2 SET X=$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
+3 SET Y=$PIECE($GET(^DPT(DFN,0)),U)
+4 QUIT $JUSTIFY(X,7)_" "_$EXTRACT(Y,1,18)
+5 ;
STATUS(DICT,DSCH) ; -- returns whether dictated on time or not
+1 IF +DICT=0
QUIT "NOT DONE"
+2 IF DICT'>DSCH
QUIT "ON TIME"
+3 QUIT "LATE"
+4 ;
CLASS(TYPE) ; -- returns 1 if doc is in dsch summ dic class (244)
+1 IF $$GET1^DIQ(8925.1,TYPE,.01)="ADDENDUM"
SET TYPE=$$GET1^DIQ(8925,IEN,.04,"I")
+2 IF $$DOCCLASS^TIULC1(TYPE)=244
QUIT 1
+3 QUIT 0
+4 ;
DSRV(CA) ; -- discharge service
+1 ;PIMS V5.3
IF $LENGTH($TEXT(^BDGF1))
QUIT $$LASTSRVN^BDGF1(CA,DFN)
+2 NEW X,Y
+3 SET Y=9999999.9999999-$GET(^DGPM(+$PIECE(^DGPM(CA,0),U,17),0))
IF 'Y
QUIT 0
+4 SET X=$ORDER(^DGPM("ATID6",+DFN,+$ORDER(^DGPM("ATID6",+DFN,Y)),0))
+5 SET X=$PIECE($GET(^DGPM(+X,0)),U,9)
+6 QUIT $$GET1^DIQ(45.7,X,.01)
+7 ;
DPRV(CA,AUTH) ; -- discharge provider
+1 IF AUTH]""
QUIT AUTH
+2 ;PIMS V5.3
IF $LENGTH($TEXT(^BDGF1))
QUIT $$LASTPRV^BDGF1(CA,DFN,"")
+3 NEW W,X,Y,Z,AP
+4 SET X=""
SET Y=0
FOR
SET Y=$ORDER(^DGPM("ATS",DFN,TIUCA,Y))
IF 'Y!(X]"")
QUIT
Begin DoDot:1
+5 SET Z=0
FOR
SET Z=$ORDER(^DGPM("ATS",DFN,TIUCA,Y,Z))
IF 'Z!(X]"")
QUIT
Begin DoDot:2
+6 SET W=0
FOR
SET W=$ORDER(^DGPM("ATS",DFN,TIUCA,Y,Z,W))
IF 'W!(X]"")
QUIT
Begin DoDot:3
+7 ;attending
SET X=$$GET1^DIQ(405,W,.19)
+8 ;admitting
IF X=""
SET AP=$$GET1^DIQ(405,W,.08)
End DoDot:3
End DoDot:2
End DoDot:1
+9 IF X=""
SET X=$SELECT($GET(AP)]"":AP,1:"??")
+10 QUIT X
+11 ;
+12 ;
SET(LINE,TIULN) ; -- sets ^tmp
+1 SET TIULN=TIULN+1
+2 SET ^TMP("BTIUDSC",$JOB,TIULN,0)=LINE
+3 QUIT
+4 ;
SET2(LINE,TIULN) ; -- sets ^tmp
+1 SET TIULN=TIULN+1
+2 SET ^TMP("BTIUDSC2",$JOB,TIULN,0)=LINE
+3 QUIT
+4 ;
PRINT ; -- print lists to paper
+1 NEW TIUX,TIUL,TIUPG
+2 USE IO
DO INIT^BTIUU
+3 FOR TIUX="BTIUDSC2","BTIUDSC"
Begin DoDot:1
+4 DO HDG
+5 SET TIUL=0
FOR
SET TIUL=$ORDER(^TMP(TIUX,$JOB,TIUL))
IF 'TIUL
QUIT
Begin DoDot:2
+6 IF $Y>(IOSL-4)
DO HDG
+7 WRITE !,^TMP(TIUX,$JOB,TIUL,0)
End DoDot:2
End DoDot:1
+8 DO ^%ZISC
DO PRTKL^BTIUU
DO EXIT
+9 QUIT
+10 ;
HDG ; -- prints 2nd half of heading
+1 SET TIUPG=$GET(TIUPG)+1
IF TIUPG>1
WRITE @IOF
+2 WRITE !,TIUTIME,?16,$$CONFID^BTIUU,?71,"Page: ",TIUPG
+3 WRITE !,TIUDATE,?24,"DISCHARGE SUMMARY DICTATION STATISTICS",?76,TIUUSR
+4 WRITE !?($LENGTH(TIUFAC\2)),TIUFAC,!,$$REPEAT^XLFSTR("-",80)
+5 ;
+6 IF TIUX="BTIUDSC2"
SET X=" Service"_$$SP(13)_"Provider"_$$SP(12)_"#DSCH Dict: On Time Late Not Done"
+7 IF '$TEST
SET X=" HRCN Patient Name"_$$SP(8)_"Provider"_$$SP(5)_"Dschargd Dictated Status"
+8 WRITE !,X,!,$$REPEAT^XLFSTR("=",80)
+9 QUIT
+10 ;
TOT(SRV,PRV,DSC,DICT) ; -- increment ^tmp for totals
+1 NEW X,Y
+2 SET X=$GET(^TMP("BTIUDSC1",$JOB,SRV,PRV))
SET Y=$GET(^TMP("BTIUDSC1",$JOB,SRV))
+3 DO INCREM
+4 SET ^TMP("BTIUDSC1",$JOB,SRV)=Y
SET ^TMP("BTIUDSC1",$JOB,SRV,PRV)=X
+5 QUIT
+6 ;
TOTL(DATA,TOTAL) ; increment grand total
+1 FOR I=1:1:4
SET $PIECE(TOTAL,U,I)=$PIECE(TOTAL,U,I)+$PIECE(DATA,U,I)
+2 QUIT
+3 ;
INCREM ; -- increment # discharges,dictated on time, late or not at all
+1 ;total dsch
SET $PIECE(X,U)=$PIECE(X,U)+1
SET $PIECE(Y,U)=$PIECE(Y,U)+1
+2 ;not dict
IF DICT=""
SET $PIECE(X,U,4)=$PIECE(X,U,4)+1
SET $PIECE(Y,U,4)=$PIECE(Y,U,4)+1
QUIT
+3 ;on time
IF DICT'>DSC
SET $PIECE(X,U,2)=$PIECE(X,U,2)+1
SET $PIECE(Y,U,2)=$PIECE(Y,U,2)+1
QUIT
+4 ;dict late
SET $PIECE(X,U,3)=$PIECE(X,U,3)+1
SET $PIECE(Y,U,3)=$PIECE(Y,U,3)+1
+5 QUIT
+6 ;
LINE2(SRV,PRV,DATA) ; -- sets up display line for totals
+1 NEW X
+2 SET X=" "_$$PAD(SRV,18)_" "_$$PAD($EXTRACT(PRV,1,18),21)
+3 SET X=X_$$PAD($JUSTIFY($PIECE(DATA,U),3),15)_$$PAD($JUSTIFY($PIECE(DATA,U,2),3),7)
+4 SET X=X_$$PAD($JUSTIFY($PIECE(DATA,U,3),3),7)_$JUSTIFY($PIECE(DATA,U,4),3)
+5 QUIT X
+6 ;
LINE3(DATA) ; -- sets up display line for totals
+1 NEW X,T,OT,LT,ND
+2 SET T=$PIECE(DATA,U)
IF 'T
SET (OT,LT,ND)=0
+3 IF '$TEST
SET OT=$PIECE(DATA,U,2)/T*100
SET LT=$PIECE(DATA,U,3)/T*100
SET ND=$PIECE(DATA,U,4)/T*100
+4 SET X=$$SP(57)_$$PAD($JUSTIFY(OT,3,0)_"%",7)
+5 SET X=X_$$PAD($JUSTIFY(LT,3,0)_"%",7)_$JUSTIFY(ND,3,0)_"%"
+6 QUIT X
+7 ;
GETIC ; -- select item from list
+1 NEW X,Y,Z,VALMY
+2 DO FULL^VALM1
+3 SET TIUICN=0
+4 DO EN^VALM2(XQORNOD(0),"OS")
+5 IF '$DATA(VALMY)
QUIT
+6 SET X=$ORDER(VALMY(0))
+7 SET Y=0
FOR
SET Y=$ORDER(^TMP("TIUZICL",$JOB,"IDX",Y))
IF Y=""
QUIT
IF TIUICN>0
QUIT
Begin DoDot:1
+8 SET Z=$ORDER(^TMP("TIUZICL",$JOB,"IDX",Y,0))
+9 IF ^TMP("TIUZICL",$JOB,"IDX",Y,Z)=""
QUIT
+10 IF Z=X
SET TIUICN=^TMP("TIUZICL",$JOB,"IDX",Y,Z)
End DoDot:1
+11 QUIT
+12 ;
ICE ;EP; -- action to edit IC file
+1 NEW TIUICN,DIE,DA,DR
+2 DO GETIC
IF 'TIUICN
DO RESET2
QUIT
+3 SET DIE="^BDGIC("
SET DA=+TIUICN
SET DR="[BTIU ICE UPDATE]"
DO ^DIE
+4 QUIT
+5 ;
ICP ;EP; -- action to print chart copy
+1 NEW TIUICN
+2 DO GETIC
IF 'TIUICN
QUIT
SET TIUDA=$PIECE(TIUICN,U,2)
IF TIUDA=""
QUIT
+3 DO PRINT1^TIURA
+4 QUIT
+5 ;
RESET ;EP; -- action to rebuild display
+1 DO TERM^VALM0
SET VALMBCK="R"
+2 DO INIT
DO HDR
QUIT
+3 ;
RESET2 ;EP; -- action to rebuild display
+1 DO TERM^VALM0
SET VALMBCK="R"
+2 DO HDR
SET VALMCNT=$ORDER(^TMP("BTIUDSC2",$JOB,""),-1)
QUIT
+3 ;
PAD(DATA,LENGTH) ; -- SUBRTN to pad length of data
+1 QUIT $EXTRACT(DATA_$$REPEAT^XLFSTR(" ",LENGTH),1,LENGTH)
+2 ;
SP(NUM) ; -- SUBRTN to pad spaces
+1 QUIT $$PAD(" ",NUM)
+2 ;
PROV() ; -- ask for provider
+1 QUIT $$READ^TIUU("PO^200","Select PROVIDER NAME")
+2 ;
ERR(NUM) ; -- sets errors
+1 SET LINE="ERROR MESSAGE: DFN="_DFN_" TIUCA="_TIUCA_" NO VISIT"
+2 DO SET(LINE,.TIULN)
+3 QUIT
