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

BDGICS1.m

Go to the documentation of this file. 
  1. BDGICS1 ; IHS/ANMC/LJF - INPATIENT CODING STATUS ;  [ 04/08/2004  4:02 PM ]
  1.  ;;5.3;PIMS;**1010,1018**;MAY 28, 2004;Build 27
  1.  ;
  1.  ;cmi/anch/maw 10/20/2008 PATCH 1010 changed export date field from .14 to 1106
  1.  ;IHS/OIT/CLS  03/31/2015 PATCH 1018 changed '=' to '[' DAY SURGERY to allow for subspecialties 
  1.  ;
  1.  NEW BDGBM,BDGEM
  1.  S BDGBM=$$READ^BDGF("DO^::EP","Select Beginning Month") Q:BDGBM<1
  1.  S BDGEM=$$READ^BDGF("DO^::EP","Select Ending Month") Q:BDGEM<1
  1.  S BDGBM=$E(BDGBM,1,5)_"00",BDGEM=$E(BDGEM,1,5)_"31.24"
  1.  ;
  1.  D ZIS^BDGF("PQ","EN^BDGICS1","INPT CODING STATUS","BDGBM;BDGEM")
  1.  Q
  1.  ;
  1.  ;
  1. EN ; -- main entry point for BDG IC CODE STATUS INPT
  1.  NEW VALMCNT
  1.  I $E(IOST,1,2)="P-" S BDGPRT=1 D INIT,PRINT Q   ;if printing to paper
  1.  D TERM^VALM0,CLEAR^VALM1
  1.  D EN^VALM("BDG IC CODE STATUS INPT")
  1.  D CLEAR^VALM1
  1.  Q
  1.  ;
  1. HDR ; -- header code
  1.  NEW X
  1.  S VALMHDR(1)=$$SP(20)_$$CONF^BDGF
  1.  S X=$$GET1^DIQ(4,DUZ(2),.01),VALMHDR(2)=$$SP(79-$L(X)\2)_X
  1.  S X=$$RANGE^BDGF(BDGBM,($E(BDGEM,1,5)_"00"))
  1.  S VALMHDR(3)=$$SP(79-$L(X)\2)_X
  1.  Q
  1.  ;
  1. INIT ; -- init variables and list array
  1.  I '$G(BDGPRT) D MSG^BDGF("Please wait while I compile the list...",2,0)
  1.  NEW DATE,TODAY,DFN,IEN,COUNT,VST,VH,MONTH,SUB,ADM,X,LINE,DSC,Y
  1.  K ^TMP("BDGICS1",$J),^TMP("BDGICS1A",$J)
  1.  S VALMCNT=0
  1.  ;
  1.  ; loop through discharges for date range
  1.  S DATE=BDGBM,TODAY=DT+.24
  1.  F  S DATE=$O(^DGPM("AMV3",DATE)) Q:('DATE)!(DATE>BDGEM)!(DATE>TODAY)  D
  1.  . S MONTH=$E(DATE,1,5)
  1.  . S DFN=0 F  S DFN=$O(^DGPM("AMV3",DATE,DFN)) Q:'DFN  D
  1.  .. S IEN=0 F  S IEN=$O(^DGPM("AMV3",DATE,DFN,IEN)) Q:'IEN  D
  1.  ... ;
  1.  ... S ADM=$$GET1^DIQ(405,IEN,.14,"I")                     ;adm ien
  1.  ... I $$LASTSRVN^BDGF1(ADM,DFN)["OBSERVATION" Q           ;inpt only
  1.  ... I $$LASTSRVN^BDGF1(ADM,DFN)["DAY SURGERY" Q           ;inpt only CHANGED FOR DAY SURGERY IHS/OCAO/CPC - 20140310
  1.  ... ;IHS/OIT/CLS 03/31/2015 patch 1018
  1.  ... ;increment # discharged per month
  1.  ... S COUNT(MONTH,"DSC")=$G(COUNT(MONTH,"DSC"))+1
  1.  ... ;
  1.  ... ; check for errors
  1.  ... S VST=$$GET1^DIQ(405,+ADM,.27,"I")                   ;visit ien
  1.  ... I 'VST D ERR("No Visit linked to ADT Admission",IEN,DATE) Q
  1.  ... I '$D(^AUPNVSIT(VST,0)) D ERR("Linked Visit doesn't exist.",IEN) Q
  1.  ... I $$GET1^DIQ(9000010,VST,.11)="DELETED" D  Q
  1.  .... D ERR("ADT Admission linked to Deleted visit.",IEN,DATE)
  1.  ... ;
  1.  ... S VH=$O(^AUPNVINP("AD",VST,0))      ;v hosp ien
  1.  ... I 'VH D ERR("No V Hospitalization for Visit",IEN,DATE) Q
  1.  ... I '$D(^AUPNVINP(VH,0)) D ERR("No V Hospitalization for Visit.",IEN,DATE) Q
  1.  ... ; check if uncoded
  1.  ... I $$GET1^DIQ(9000010.02,VH,.15)="NO" D UNCODED(DATE,IEN) Q
  1.  ... ;
  1.  ... ; check if exported
  1.  ... S COUNT(MONTH,"COD")=$G(COUNT(MONTH,"COD"))+1
  1.  ... ;I $$GET1^DIQ(9000010,VST,.14)]"" S COUNT(MONTH,"EXP")=$G(COUNT(MONTH,"EXP"))+1  ;cmi/maw 10/20/2008 orig line
  1.  ... I $$GET1^DIQ(9000010,VST,1106)]"" S COUNT(MONTH,"EXP")=$G(COUNT(MONTH,"EXP"))+1  ;cmi/maw 10/20/2008 PATCH 1010 modified for new data export field
  1.  ;
  1.  ; build display array
  1.  ;    monthly counts heading
  1.  S LINE=$$PAD($$PAD("Month/Year",15)_"# Disch",26)
  1.  S LINE=$$PAD($$PAD(LINE_"# Coded",36)_"# Not-Coded",50)
  1.  S LINE=$$PAD(LINE_"# Exported",63)_"# Errors"
  1.  D SET(LINE,.VALMCNT)
  1.  ;    monthly counts
  1.  S MON=0 F  S MON=$O(COUNT(MON)) Q:'MON  D
  1.  . S LINE=$$PAD($$FMTE^XLFDT(MON_"00"),15)
  1.  . F SUB="DSC","COD","UNC","EXP","ERR" D
  1.  .. S LINE=LINE_$J(+$G(COUNT(MON,SUB)),4)_$$SP(8)
  1.  . D SET(LINE,.VALMCNT)
  1.  ;
  1.  ;IHS/ITSC/LJF 4/8/2004 add totals for each column
  1.  D SET($$REPEAT^XLFSTR("=",79),.VALMCNT)
  1.  S LINE=$$SP(15)
  1.  F SUB="DSC","COD","UNC","EXP","ERR" D
  1.  . S TOTAL=0,MON=0
  1.  . F  S MON=$O(COUNT(MON)) Q:'MON  S TOTAL=$G(TOTAL)+$G(COUNT(MON,SUB))
  1.  . S LINE=LINE_$J(TOTAL,4)_$$SP(8)
  1.  D SET(LINE,.VALMCNT)
  1.  ;IHS/ITSC/LJF 4/8/2004 end of new code
  1.  ;
  1.  D SET("",.VALMCNT)
  1.  ;
  1.  ; list uncoded charts
  1.  ;   if any uncoded charts, print heading
  1.  I $D(^TMP("BDGICS1A",$J,"U")) D
  1.  . S LINE=$$PAD("Admit & Dscharge Dates",24)
  1.  . S LINE=$$PAD($$PAD(LINE_"Patient Name",48)_"Chart #",58)
  1.  . S LINE=$$PAD(LINE_"Srv",64)_"Insurance"
  1.  . D SET("",.VALMCNT),SET(LINE,.VALMCNT)
  1.  ;
  1.  S DSC=0 F  S DSC=$O(^TMP("BDGICS1A",$J,"U",DSC)) Q:'DSC  D
  1.  . S IEN=0 F  S IEN=$O(^TMP("BDGICS1A",$J,"U",DSC,IEN)) Q:'IEN  D
  1.  .. ;
  1.  .. S ADM=$$GET1^DIQ(405,IEN,.14,"I")                        ;adm ien
  1.  .. S DFN=$$GET1^DIQ(405,IEN,.03,"I")                        ;pat ien
  1.  .. ;
  1.  .. S LINE=$$PAD($$NUMDATE^BDGF(+$G(^DGPM(ADM,0))\1),12)  ;adm date
  1.  .. S LINE=$$PAD(LINE_$$NUMDATE^BDGF(DSC\1),24)           ;dsc date
  1.  .. S LINE=$$PAD(LINE_$E($$GET1^DIQ(405,IEN,.03),1,22),48)   ;name
  1.  .. S LINE=LINE_$J($$HRCN^BDGF2(DFN,DUZ(2)),6)
  1.  .. S LINE=$$PAD(LINE,58)_$P($$LASTSRVC^BDGF1(ADM,DFN)," ")  ;srv
  1.  .. ;
  1.  .. ; add insurance coverage
  1.  .. S LINE=$$PAD(LINE,64)_$$INSUR^BDGF2(DFN,+^DGPM(ADM,0))
  1.  .. D SET(LINE,.VALMCNT)
  1.  ;
  1.  ; add error charts to display listing
  1.  ;     if any errors, print heading
  1.  I $D(^TMP("BDGICS1A",$J,"E")) D
  1.  . I $E(IOST,1,2)="P-" D SET("@@@",.VALMCNT)   ;mark errors for paper
  1.  . S LINE=$$PAD("Discharge Date",16)_"Patient Name"
  1.  . S LINE=$$PAD($$PAD(LINE,38)_"Chart #",48)_"Error Message"
  1.  . D SET("",.VALMCNT),SET(LINE,.VALMCNT)
  1.  ;
  1.  S DSC=0 F  S DSC=$O(^TMP("BDGICS1A",$J,"E",DSC)) Q:'DSC  D
  1.  . S IEN=0 F  S IEN=$O(^TMP("BDGICS1A",$J,"E",DSC,IEN)) Q:'IEN  D
  1.  .. ;
  1.  .. S DFN=$$GET1^DIQ(405,IEN,.03,"I")                        ;pat ien
  1.  .. S LINE=$$PAD($$NUMDATE^BDGF(DSC\1),16)                   ;dsc date
  1.  .. S LINE=$$PAD(LINE_$E($$GET1^DIQ(405,IEN,.03),1,18),38)   ;name
  1.  .. S LINE=LINE_$J($$HRCN^BDGF2(DFN,DUZ(2)),6)               ;chart #
  1.  .. S LINE=$$PAD(LINE,48)_^TMP("BDGICS1A",$J,"E",DSC,IEN)    ;err msg
  1.  .. D SET(LINE,.VALMCNT)
  1.  ;
  1.  I '$D(^TMP("BDGICS1",$J)) D SET("NO DATA FOUND",.VALMCNT)
  1.  K ^TMP("BDGICS1A",$J)
  1.  Q
  1.  ;
  1. ERR(MSG,IEN,DATE) ; increment error count and save for listing
  1.  NEW MON
  1.  S MON=$E(DATE,1,5)
  1.  S COUNT(MON,"ERR")=$G(COUNT(MON,"ERR"))+1
  1.  S ^TMP("BDGICS1A",$J,"E",DATE,IEN)=MSG
  1.  Q
  1.  ;
  1. UNCODED(DATE,IEN) ; save uncoded visits by discharge date
  1.  NEW MON
  1.  S MON=$E(DATE,1,5)
  1.  S COUNT(MON,"UNC")=$G(COUNT(MON,"UNC"))+1
  1.  S ^TMP("BDGICS1A",$J,"U",DATE,IEN)=""
  1.  Q
  1.  ;
  1. SET(DATA,NUM) ; put data line into display array
  1.  S NUM=NUM+1
  1.  S ^TMP("BDGICS1",$J,NUM,0)=DATA
  1.  Q
  1.  ;
  1. PRINT ; print report to paper
  1.  NEW BDGL,FIRST
  1.  U IO S FIRST=1 D HDG
  1.  S BDGL=0 F  S BDGL=$O(^TMP("BDGICS1",$J,BDGL)) Q:'BDGL  D
  1.  . I ^TMP("BDGICS1",$J,BDGL,0)="@@@" S FIRST=1 Q  ;beginning of errors
  1.  . I $Y>(IOSL-4) D HDG
  1.  . W !,^TMP("BDGICS1",$J,BDGL,0)
  1.  D ^%ZISC,EXIT
  1.  Q
  1.  ;
  1. HDG ; heading when printing to paper
  1.  ;W @IOF W !?20,"INPATIENT CODING STATUS REPORT"
  1.  I 'FIRST W @IOF                           ;IHS/ITSC/LJF 1/15/2004
  1.  W !?20,"INPATIENT CODING STATUS REPORT"   ;IHS/ITSC/LJF 1/15/2004
  1.  D HDR F I=1:1 Q:'$D(VALMHDR(I))  W !,VALMHDR(I)
  1.  I FIRST W !,$$REPEAT^XLFSTR("=",80),! S FIRST=0 Q
  1.  W !,"Discharge/Admit Dates",?24,"Patient Name",?44,"Chart #"
  1.  W !?54,"Serv",?60,"Insurance",!,$$REPEAT^XLFSTR("=",80),!
  1.  Q
  1.  ;
  1. HELP ; -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXIT ; -- exit code
  1.  K ^TMP("BDGICS1",$J) K BDGPRT
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  1.  Q
  1.  ;
  1. PAD(D,L) ;EP -- SUBRTN to pad length of data
  1.  ; -- D=data L=length
  1.  Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)
  1.  ;
  1. SP(N) ; -- SUBRTN to pad N number of spaces
  1.  Q $$PAD(" ",N)