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

BDGICR4.m

Go to the documentation of this file. 
  1. BDGICR4 ; IHS/ANMC/LJF - CODED A SHEET REPORTS ; 
  1.  ;;5.3;PIMS;**1009,1010**;APR 26, 2002
  1.  ;
  1.  ;cmi/anch/maw 02/19/2009 PATCH 1009 requirement 67 in GATHER
  1.  ;
  1.  D ^XBCLS
  1.  D MSG^BDGF($$SP(20)_"CODED A SHEET REPORTS",2,2)
  1.  NEW Y S Y=$$READ^BDGF("SO^1:WITH DATE CODED;2:WITH DATE EXPORTED","Select CODED A SHEET REPORT") Q:'Y  I +Y=1 D ^BDGICR41 Q
  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^BDGICR4","EXPORTED A SHEETS","BDGBD;BDGED")
  1.  Q
  1.  ;
  1. EN ;EP; -- main entry point for BDG IC DATE EXPORTED
  1.  NEW VALMCNT
  1.  I IOST'["C-" D GATHER(BDGBD,BDGED),PRINT Q
  1.  D TERM^VALM0
  1.  D EN^VALM("BDG IC DATE EXPORTED")
  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("BDGICR4",$J) K BDGLN
  1.  Q
  1.  ;
  1. EXIT2 ;EP; -- exit code for patient listing
  1.  K VALMCNT 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,BDGETOT,LINE,VDT
  1.  K ^TMP("BDGICR4",$J),^TMP("BDGICR4A",$J)
  1.  ;
  1.  ; loop through hospitalizations by date and sort by date then name
  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),NAME=$P(^DPT(DFN,0),U),VDT=$P(DATA,U)
  1.  .. S ^TMP("BDGICR4A",$J,$P(DATE,"."),NAME,DFN,VH)=VST_U_VDT
  1.  ;
  1.  ; loop through sorted list and put into display array
  1.  S DATE=0,(BDGTOT,BDGETOT)=0
  1.  F  S DATE=$O(^TMP("BDGICR4A",$J,DATE)) Q:'DATE  D
  1.  . ;
  1.  . D SET("",.BDGLN),SET($$SP(20)_"DISCHARGED ON: "_$$DATE(DATE),.BDGLN)
  1.  . ;
  1.  . S NAME=0 F  S NAME=$O(^TMP("BDGICR4A",$J,DATE,NAME)) Q:NAME=""  D
  1.  .. S DFN=0 F  S DFN=$O(^TMP("BDGICR4A",$J,DATE,NAME,DFN)) Q:'DFN  D
  1.  ... S VH=0 F  S VH=$O(^TMP("BDGICR4A",$J,DATE,NAME,DFN,VH)) Q:'VH  D
  1.  .... ;
  1.  .... S DATA=^TMP("BDGICR4A",$J,DATE,NAME,DFN,VH)
  1.  .... S VST=+DATA,VDT=$P(DATA,U,2),BDGTOT=BDGTOT+1
  1.  .... S HRCN=$$HRCN^BDGF2(DFN,DUZ(2))
  1.  .... S LINE=" "_$$PAD($E(NAME,1,20),26)_$J(HRCN,6)   ;name & chart #
  1.  .... S LINE=$$PAD(LINE,40)_$$DATE(VDT) ;admit date
  1.  .... S LINE=$$PAD(LINE,52)_$$DATE($$GET1^DIQ(9000010,VST,.13,"I")) ;mod
  1.  .... ;S Y=$$GET1^DIQ(9000010,VST,.14,"I") I Y]"" S BDGETOT=BDGETOT+1  ;cmi/maw 2/19/2008 orig line PATCH 1009 requirement 67
  1.  .... S Y=$$GET1^DIQ(9000010,VST,1106,"I") I Y]"" S BDGETOT=BDGETOT+1  ;cmi/maw 2/19/2008 PATCH 1008 requirement 67
  1.  .... I Y S LINE=$$PAD(LINE,64)_$$DATE(Y)  ;date exported
  1.  .... D SET(LINE,.BDGLN)
  1.  ;
  1.  S LINE=$$SP(5)_"Total Coded: "_BDGTOT
  1.  S LINE=$$PAD(LINE,40)_"Total Exported: "_BDGETOT
  1.  D SET("",.BDGLN),SET(LINE,.BDGLN)
  1.  ;
  1.  K ^TMP("BDGICR4A",$J)
  1.  Q
  1.  ;
  1. SET(LINE,BDGLN) ; -- sets ^tmp
  1.  S BDGLN=BDGLN+1
  1.  S ^TMP("BDGICR4",$J,BDGLN,0)=LINE
  1.  Q
  1.  ;
  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("BDGICR4",$J,BDGL)) Q:'BDGL  D
  1.  . I $Y>(IOSL-4) D HDG
  1.  . W !,^TMP("BDGICR4",$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 EXPORT DATE",?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,"Admitted",?52,"Modified"
  1.  W ?64,"Exported",!,$$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")