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

BDGICR41.m

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