BDGICR41 ; IHS/ANMC/LJF - CODED A SHEET REPORTS ;
;;5.3;PIMS;**1005**;MAY 28, 2004
;IHS/OIT/LJF 12/21/2005 PATCH 1005 fixed code in case primary provider not first entered
;
NEW BDGED,BDGBD
S BDGBD=$$READ^BDGF("DO^::E","Select BEGINNING Discharge Date")
Q:BDGBD<1
S BDGED=$$READ^BDGF("DO^::E","Select ENDING Discharge Date")
Q:BDGED<1
D ZIS^BDGF("PQ","EN^BDGICR41","CODED A SHEETS","BDGBD;BDGED")
Q
;
EN ; -- main entry point for BDG IC DATE CODED
NEW VALMCNT
I IOST'["C-" D GATHER(BDGBD,BDGED),PRINT Q
D TERM^VALM0
D EN^VALM("BDG IC DATE CODED")
Q
;
HDR ;EP; -- header code
S VALMHDR(1)=$$SP(20)_$$CONF^BDGF
Q
;
INIT ;EP; -- init variables and list array
NEW BDGLN
D MSG^BDGF("Building/Updating Display. . .Please wait.",2,0)
D GATHER(BDGBD,BDGED)
S VALMCNT=BDGLN
Q
;
HELP ;EP; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ;EP; -- exit code
K ^TMP("BDGICR41",$J) K BDGLN
Q
;
EXPND ; -- expand code
Q
;
GATHER(BDGBD,BDGED) ; -- create display array
NEW DATE,VH,VST,DATA,DFN,NAME,BDGTOT,LINE,VDT,BDGSTOT
K ^TMP("BDGICR41",$J),^TMP("BDGICR41A",$J)
;
; loop through hospitalizations by date & sort by service and date
S DATE=BDGBD-.0001,BDGLN=0
F S DATE=$O(^AUPNVINP("B",DATE)) Q:'DATE!(DATE>(BDGED+.24)) D
. S VH=0 F S VH=$O(^AUPNVINP("B",DATE,VH)) Q:'VH D
.. ;
.. Q:'$D(^AUPNVINP(VH,0)) S VST=$P(^(0),U,3)
.. Q:$P(^AUPNVINP(VH,0),U,15)'="" ;check coded flag
.. Q:'$D(^AUPNVSIT(VST,0)) S DATA=^(0)
.. Q:$P(DATA,U,11)'="" ;screen out deleted visits
.. Q:$P(DATA,U,6)'=DUZ(2) ;screen out other facilities
.. S DFN=$P(DATA,U,5),SRV=$$GET1^DIQ(9000010.02,VH,.05)
.. S ^TMP("BDGICR41A",$J,SRV,DATE,VH)=VST_U_DFN
;
; now loop through sorted list and put into display array
S SRV=0,BDGTOT=0
F S SRV=$O(^TMP("BDGICR41A",$J,SRV)) Q:SRV="" D
. ;
. D SET("",.BDGLN),SET($$SP(5)_"SERVICE: "_SRV,.BDGLN) K BDGSTOT
. ;
. S BDGD=0 F S BDGD=$O(^TMP("BDGICR41A",$J,SRV,BDGD)) Q:BDGD="" D
.. S VH=0 F S VH=$O(^TMP("BDGICR41A",$J,SRV,BDGD,VH)) Q:'VH D
... ;
... S DATA=^TMP("BDGICR41A",$J,SRV,BDGD,VH)
... S VST=+DATA,DFN=$P(DATA,U,2),BDGTOT=BDGTOT+1
... S LINE=" "_$E($$GET1^DIQ(2,DFN,.01),1,20) ;name
... S LINE=$$PAD(LINE,26)_$J($$HRCN^BDGF2(DFN,DUZ(2)),6) ;chart #
... S LINE=$$PAD(LINE,40)_$$DATE(BDGD) ;disch date
... S CODE=$$CODE(VST),DIFF=$$DAYS(BDGD,CODE)
... S LINE=$$PAD(LINE,50)_$$DATE(CODE) ;date coded
... S LINE=$$PAD(LINE,60)_$J(DIFF,3) ;days to code
... S PROV=$$PPROV(VST) ;prim prov
... S LINE=$$PAD(LINE,67)_$E(PROV,1,13)
... D SET(LINE,.BDGLN),COUNT(DIFF)
. ;
. ; at end of service listing
. D SET("",.BDGLN)
. D SET($$SP(22)_"# Coded Low High Average",.BDGLN)
. S LINE="Totals for Service: "_$J($P(BDGSTOT,U),4)
. S LINE=$$PAD(LINE,33)_$J($P(BDGSTOT,U,2),3)
. S LINE=$$PAD(LINE,40)_$J($P(BDGSTOT,U,3),3)
. S X=$P(BDGSTOT,U,4)/$P(BDGSTOT,U)
. S LINE=$$PAD(LINE,47)_$J(X,5,2) D SET(LINE,.BDGLN)
;
S LINE=$$SP(5)_"Total Coded: "_BDGTOT
D SET("",.BDGLN),SET(LINE,.BDGLN)
;
K ^TMP("BDGICR41A",$J)
Q
;
SET(LINE,BDGLN) ; -- sets ^tmp
S BDGLN=BDGLN+1
S ^TMP("BDGICR41",$J,BDGLN,0)=LINE
Q
;
PRINT ; -- print lists to paper
NEW BDGX,BDGL,BDGPG
U IO D INIT^BDGF,HDG
;
S BDGL=0 F S BDGL=$O(^TMP("BDGICR41",$J,BDGL)) Q:'BDGL D
. I $Y>(IOSL-4) D HDG
. W !,^TMP("BDGICR41",$J,BDGL,0)
;
D ^%ZISC,PRTKL^BDGF,EXIT
Q
;
HDG ; -- heading when printing to paper
S BDGPG=$G(BDGPG)+1 I BDGPG>1 W @IOF
W !,BDGUSR,?16,$$CONF^BDGF
W !,BDGDATE,?25,"CODED A SHEETS WITH DATE CODED",?71,"Page: ",BDGPG
NEW X S X=$$FMTE^XLFDT(BDGBD)_" to "_$$FMTE^XLFDT(BDGED)
W !,BDGTIME,?(80-$L(X)\2),X
W !,$$REPEAT^XLFSTR("-",80)
W !,"Patient Name",?27,"Chart #",?40,"Dischrgd Coded",?61,"Days"
W ?67,"Provider"
W !,$$REPEAT^XLFSTR("=",80)
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)
;
DATE(X) ; -- returns date in readable format
NEW Y S Y=$$FMTE^XLFDT(X,"2DF")
Q $TR(Y," ","0")
;
PPROV(VST) ; -- returns name of primary provider for visit
NEW X,PROV
;S X=0 F S X=$O(^AUPNVPRV("AD",VST,0)) Q:'X!($G(PROV)]"") D
S X=0 F S X=$O(^AUPNVPRV("AD",VST,X)) Q:'X!($G(PROV)]"") D ;IHS/OIT/LJF 12/21/2005 PATCH 1005
. Q:$$GET1^DIQ(9000010.06,X,.04,"I")'="P"
. S PROV=$$GET1^DIQ(9000010.06,X,.01)
Q $G(PROV)
;
CODE(VST) ; -- returns date coded
NEW IEN,PRV,CODE,DATE
; first look in IC file
S IEN=$O(^BDGIC("AV",VST,0))
I IEN Q $$GET1^DIQ(9009016.1,IEN,.13,"I")
;
; then check if coder entered as provider on visit
S PRV=0 F S PRV=$O(^AUPNVPRV("AD",VST,PRV)) Q:'PRV!($G(DATE)) D
. S CODE=$$GET1^DIQ(9000010.06,PRV,.019) Q:$E(CODE,2,3)'=88
. S DATE=$$GET1^DIQ(9000010.06,PRV,1201,"I")
Q $G(DATE)
;
DAYS(DSCH,CODE) ; -- returns difference between dsch and coding
I CODE="" Q "??"
NEW X1,X2,X S X1=CODE,X2=DSCH D ^%DTC Q X
;
COUNT(DIFF) ; -- sets array to hold service counts
I '$D(BDGSTOT) S BDGSTOT=1_U_DIFF_U_DIFF_U_DIFF Q
S $P(BDGSTOT,U)=$P(BDGSTOT,U)+1 ;increment count
I DIFF<$P(BDGSTOT,U,2) S $P(BDGSTOT,U,2)=DIFF
I DIFF>$P(BDGSTOT,U,3) S $P(BDGSTOT,U,3)=DIFF
S $P(BDGSTOT,U,4)=$P(BDGSTOT,U,4)+DIFF
Q
BDGICR41 ; IHS/ANMC/LJF - CODED A SHEET REPORTS ;
+1 ;;5.3;PIMS;**1005**;MAY 28, 2004
+2 ;IHS/OIT/LJF 12/21/2005 PATCH 1005 fixed code in case primary provider not first entered
+3 ;
+4 NEW BDGED,BDGBD
+5 SET BDGBD=$$READ^BDGF("DO^::E","Select BEGINNING Discharge Date")
+6 IF BDGBD<1
QUIT
+7 SET BDGED=$$READ^BDGF("DO^::E","Select ENDING Discharge Date")
+8 IF BDGED<1
QUIT
+9 DO ZIS^BDGF("PQ","EN^BDGICR41","CODED A SHEETS","BDGBD;BDGED")
+10 QUIT
+11 ;
EN ; -- main entry point for BDG IC DATE CODED
+1 NEW VALMCNT
+2 IF IOST'["C-"
DO GATHER(BDGBD,BDGED)
DO PRINT
QUIT
+3 DO TERM^VALM0
+4 DO EN^VALM("BDG IC DATE CODED")
+5 QUIT
+6 ;
HDR ;EP; -- header code
+1 SET VALMHDR(1)=$$SP(20)_$$CONF^BDGF
+2 QUIT
+3 ;
INIT ;EP; -- init variables and list array
+1 NEW BDGLN
+2 DO MSG^BDGF("Building/Updating Display. . .Please wait.",2,0)
+3 DO GATHER(BDGBD,BDGED)
+4 SET VALMCNT=BDGLN
+5 QUIT
+6 ;
HELP ;EP; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ;EP; -- exit code
+1 KILL ^TMP("BDGICR41",$JOB)
KILL BDGLN
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
GATHER(BDGBD,BDGED) ; -- create display array
+1 NEW DATE,VH,VST,DATA,DFN,NAME,BDGTOT,LINE,VDT,BDGSTOT
+2 KILL ^TMP("BDGICR41",$JOB),^TMP("BDGICR41A",$JOB)
+3 ;
+4 ; loop through hospitalizations by date & sort by service and date
+5 SET DATE=BDGBD-.0001
SET BDGLN=0
+6 FOR
SET DATE=$ORDER(^AUPNVINP("B",DATE))
IF 'DATE!(DATE>(BDGED+.24))
QUIT
Begin DoDot:1
+7 SET VH=0
FOR
SET VH=$ORDER(^AUPNVINP("B",DATE,VH))
IF 'VH
QUIT
Begin DoDot:2
+8 ;
+9 IF '$DATA(^AUPNVINP(VH,0))
QUIT
SET VST=$PIECE(^(0),U,3)
+10 ;check coded flag
IF $PIECE(^AUPNVINP(VH,0),U,15)'=""
QUIT
+11 IF '$DATA(^AUPNVSIT(VST,0))
QUIT
SET DATA=^(0)
+12 ;screen out deleted visits
IF $PIECE(DATA,U,11)'=""
QUIT
+13 ;screen out other facilities
IF $PIECE(DATA,U,6)'=DUZ(2)
QUIT
+14 SET DFN=$PIECE(DATA,U,5)
SET SRV=$$GET1^DIQ(9000010.02,VH,.05)
+15 SET ^TMP("BDGICR41A",$JOB,SRV,DATE,VH)=VST_U_DFN
End DoDot:2
End DoDot:1
+16 ;
+17 ; now loop through sorted list and put into display array
+18 SET SRV=0
SET BDGTOT=0
+19 FOR
SET SRV=$ORDER(^TMP("BDGICR41A",$JOB,SRV))
IF SRV=""
QUIT
Begin DoDot:1
+20 ;
+21 DO SET("",.BDGLN)
DO SET($$SP(5)_"SERVICE: "_SRV,.BDGLN)
KILL BDGSTOT
+22 ;
+23 SET BDGD=0
FOR
SET BDGD=$ORDER(^TMP("BDGICR41A",$JOB,SRV,BDGD))
IF BDGD=""
QUIT
Begin DoDot:2
+24 SET VH=0
FOR
SET VH=$ORDER(^TMP("BDGICR41A",$JOB,SRV,BDGD,VH))
IF 'VH
QUIT
Begin DoDot:3
+25 ;
+26 SET DATA=^TMP("BDGICR41A",$JOB,SRV,BDGD,VH)
+27 SET VST=+DATA
SET DFN=$PIECE(DATA,U,2)
SET BDGTOT=BDGTOT+1
+28 ;name
SET LINE=" "_$EXTRACT($$GET1^DIQ(2,DFN,.01),1,20)
+29 ;chart #
SET LINE=$$PAD(LINE,26)_$JUSTIFY($$HRCN^BDGF2(DFN,DUZ(2)),6)
+30 ;disch date
SET LINE=$$PAD(LINE,40)_$$DATE(BDGD)
+31 SET CODE=$$CODE(VST)
SET DIFF=$$DAYS(BDGD,CODE)
+32 ;date coded
SET LINE=$$PAD(LINE,50)_$$DATE(CODE)
+33 ;days to code
SET LINE=$$PAD(LINE,60)_$JUSTIFY(DIFF,3)
+34 ;prim prov
SET PROV=$$PPROV(VST)
+35 SET LINE=$$PAD(LINE,67)_$EXTRACT(PROV,1,13)
+36 DO SET(LINE,.BDGLN)
DO COUNT(DIFF)
End DoDot:3
End DoDot:2
+37 ;
+38 ; at end of service listing
+39 DO SET("",.BDGLN)
+40 DO SET($$SP(22)_"# Coded Low High Average",.BDGLN)
+41 SET LINE="Totals for Service: "_$JUSTIFY($PIECE(BDGSTOT,U),4)
+42 SET LINE=$$PAD(LINE,33)_$JUSTIFY($PIECE(BDGSTOT,U,2),3)
+43 SET LINE=$$PAD(LINE,40)_$JUSTIFY($PIECE(BDGSTOT,U,3),3)
+44 SET X=$PIECE(BDGSTOT,U,4)/$PIECE(BDGSTOT,U)
+45 SET LINE=$$PAD(LINE,47)_$JUSTIFY(X,5,2)
DO SET(LINE,.BDGLN)
End DoDot:1
+46 ;
+47 SET LINE=$$SP(5)_"Total Coded: "_BDGTOT
+48 DO SET("",.BDGLN)
DO SET(LINE,.BDGLN)
+49 ;
+50 KILL ^TMP("BDGICR41A",$JOB)
+51 QUIT
+52 ;
SET(LINE,BDGLN) ; -- sets ^tmp
+1 SET BDGLN=BDGLN+1
+2 SET ^TMP("BDGICR41",$JOB,BDGLN,0)=LINE
+3 QUIT
+4 ;
PRINT ; -- print lists to paper
+1 NEW BDGX,BDGL,BDGPG
+2 USE IO
DO INIT^BDGF
DO HDG
+3 ;
+4 SET BDGL=0
FOR
SET BDGL=$ORDER(^TMP("BDGICR41",$JOB,BDGL))
IF 'BDGL
QUIT
Begin DoDot:1
+5 IF $Y>(IOSL-4)
DO HDG
+6 WRITE !,^TMP("BDGICR41",$JOB,BDGL,0)
End DoDot:1
+7 ;
+8 DO ^%ZISC
DO PRTKL^BDGF
DO EXIT
+9 QUIT
+10 ;
HDG ; -- heading when printing to paper
+1 SET BDGPG=$GET(BDGPG)+1
IF BDGPG>1
WRITE @IOF
+2 WRITE !,BDGUSR,?16,$$CONF^BDGF
+3 WRITE !,BDGDATE,?25,"CODED A SHEETS WITH DATE CODED",?71,"Page: ",BDGPG
+4 NEW X
SET X=$$FMTE^XLFDT(BDGBD)_" to "_$$FMTE^XLFDT(BDGED)
+5 WRITE !,BDGTIME,?(80-$LENGTH(X)\2),X
+6 WRITE !,$$REPEAT^XLFSTR("-",80)
+7 WRITE !,"Patient Name",?27,"Chart #",?40,"Dischrgd Coded",?61,"Days"
+8 WRITE ?67,"Provider"
+9 WRITE !,$$REPEAT^XLFSTR("=",80)
+10 QUIT
+11 ;
+12 ;
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 ;
DATE(X) ; -- returns date in readable format
+1 NEW Y
SET Y=$$FMTE^XLFDT(X,"2DF")
+2 QUIT $TRANSLATE(Y," ","0")
+3 ;
PPROV(VST) ; -- returns name of primary provider for visit
+1 NEW X,PROV
+2 ;S X=0 F S X=$O(^AUPNVPRV("AD",VST,0)) Q:'X!($G(PROV)]"") D
+3 ;IHS/OIT/LJF 12/21/2005 PATCH 1005
SET X=0
FOR
SET X=$ORDER(^AUPNVPRV("AD",VST,X))
IF 'X!($GET(PROV)]"")
QUIT
Begin DoDot:1
+4 IF $$GET1^DIQ(9000010.06,X,.04,"I")'="P"
QUIT
+5 SET PROV=$$GET1^DIQ(9000010.06,X,.01)
End DoDot:1
+6 QUIT $GET(PROV)
+7 ;
CODE(VST) ; -- returns date coded
+1 NEW IEN,PRV,CODE,DATE
+2 ; first look in IC file
+3 SET IEN=$ORDER(^BDGIC("AV",VST,0))
+4 IF IEN
QUIT $$GET1^DIQ(9009016.1,IEN,.13,"I")
+5 ;
+6 ; then check if coder entered as provider on visit
+7 SET PRV=0
FOR
SET PRV=$ORDER(^AUPNVPRV("AD",VST,PRV))
IF 'PRV!($GET(DATE))
QUIT
Begin DoDot:1
+8 SET CODE=$$GET1^DIQ(9000010.06,PRV,.019)
IF $EXTRACT(CODE,2,3)'=88
QUIT
+9 SET DATE=$$GET1^DIQ(9000010.06,PRV,1201,"I")
End DoDot:1
+10 QUIT $GET(DATE)
+11 ;
DAYS(DSCH,CODE) ; -- returns difference between dsch and coding
+1 IF CODE=""
QUIT "??"
+2 NEW X1,X2,X
SET X1=CODE
SET X2=DSCH
DO ^%DTC
QUIT X
+3 ;
COUNT(DIFF) ; -- sets array to hold service counts
+1 IF '$DATA(BDGSTOT)
SET BDGSTOT=1_U_DIFF_U_DIFF_U_DIFF
QUIT
+2 ;increment count
SET $PIECE(BDGSTOT,U)=$PIECE(BDGSTOT,U)+1
+3 IF DIFF<$PIECE(BDGSTOT,U,2)
SET $PIECE(BDGSTOT,U,2)=DIFF
+4 IF DIFF>$PIECE(BDGSTOT,U,3)
SET $PIECE(BDGSTOT,U,3)=DIFF
+5 SET $PIECE(BDGSTOT,U,4)=$PIECE(BDGSTOT,U,4)+DIFF
+6 QUIT
