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

BDGPCCE2.m

Go to the documentation of this file. 
  1. BDGPCCE2 ; IHS/ANMC/LJF - PULL UP ALL I VISITS ; 
  1.  ;;5.3;PIMS;**1005,1016**;MAY 28, 2004;Build 20
  1.  ;IHS/OIT/LJF 04/14/2006 PATCH 1005 added ;EP to EN - called by BDGPCCEL
  1.  ;
  1. EN ;EP -- main entry point for BDG IC I VISITS ;IHS/OIT/LJF 04/14/2006 PATCH 1005
  1.  ; Assumes DFN and BDGV are set
  1.  D MSG^BDGF("Please wait while I compile the list...",1,0)
  1.  NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
  1.  D EN^VALM("BDG IC I VISITS")
  1.  D CLEAR^VALM1
  1.  Q
  1.  ;
  1. HDR ; -- header code
  1.  NEW X,Y,VH
  1.  S VALMHDR(1)=$$SP(15)_$$CONF^BDGF
  1.  ;
  1.  S X=$$GET1^DIQ(2,DFN,.01)_$$SP(5)_$$HRCN^BDGF2(DFN,DUZ(2))
  1.  S VALMHDR(2)=$$SP(79-$L(X)\2)_X
  1.  ;
  1.  S X="Admitted on "_$$GET1^DIQ(9000010,BDGV,.01)
  1.  S VALMHDR(3)=$$SP(79-$L(X)\2)_X
  1.  Q
  1.  ;
  1. INIT ; -- init variables and list array
  1.  K ^TMP("BDGPCCE2",$J)
  1.  S VALMCNT=0
  1.  NEW ADM,DSC,BEG,DATE,VST,COUNT,LINE
  1.  S ADM=$$GET1^DIQ(9000010,BDGV,.01,"I")\1           ;admit date
  1.  S BEG=$$FMADD^XLFDT(ADM,-3)                        ;72/24 rule
  1.  S DSC=$$GET1^DIQ(9000010.02,+$O(^AUPNVINP("AD",BDGV,0)),.01,"I")
  1.  I DSC="" S DSC=DT
  1.  S BEG=(9999999-BEG)_".9999999",DATE=9999999-DSC
  1.  ;
  1.  F  S DATE=$O(^AUPNVSIT("AA",DFN,DATE)) Q:'DATE  Q:(DATE>BEG)  D
  1.  . S VST=0 F  S VST=$O(^AUPNVSIT("AA",DFN,DATE,VST)) Q:'VST  D
  1.  .. I "HCTE"[$$GET1^DIQ(9000010,VST,.07,"I") Q
  1.  .. I $$GET1^DIQ(9000010,VST,.11)="DELETED" Q
  1.  .. I $$GET1^DIQ(9000010,VST,.06,"I")'=DUZ(2) Q  ;wrong facility
  1.  .. ;
  1.  .. S COUNT=$G(COUNT)+1   ;number used to select visit for editing
  1.  .. ;S LINE=$J(COUNT,3)_". "_$$GET1^DIQ(9000010,VST,.01)    ;vist date
  1.  .. ;ihs/cmi/maw 07/02/2012 PATCH 1016 added a space to visit date
  1.  .. S LINE=$J(COUNT,4)_". "_$$GET1^DIQ(9000010,VST,.01)    ;vist date
  1.  .. S LINE=$$PAD(LINE,30)_$$GET1^DIQ(9000010,VST,.07,"I")  ;ser categ
  1.  .. ;
  1.  .. ; find all llinks v files to this visit
  1.  .. K BDGA D VFILES(VST,.BDGA)
  1.  .. I '$D(BDGA) D  Q
  1.  ... D SET($$PAD(LINE,40)_"No Dependent Entries",.VALMCNT,COUNT,VST)
  1.  .. ;
  1.  .. S FIRST=1,NAME=0 F  S NAME=$O(BDGA(NAME)) Q:NAME=""  D
  1.  ... S LINE=$$PAD(LINE,40)_$S(FIRST:"Has ",1:$$SP(4))
  1.  ... S LINE=LINE_$J(BDGA(NAME),4)_" "_NAME
  1.  ... D SET(LINE,.VALMCNT,COUNT,VST) S LINE=$$SP(40)
  1.  .. D SET("",.VALMCNT,COUNT,VST)
  1.  ;
  1.  I '$D(^TMP("BDGPCCE2",$J)) D SET("No Visits Found",.VALMCNT,1,0)
  1.  Q
  1.  ;
  1. VFILES(V,ARRAY) ; find linked v files and counts
  1.  NEW FILE,GLOBAL,IEN,NAME
  1.  S FILE=9000010
  1.  F  S FILE=$O(^DIC(FILE)) Q:'FILE  Q:(FILE>9000010.9999)  D
  1.  . S GLOBAL=$G(^DIC(FILE,0,"GL")) Q:GLOBAL=""
  1.  . S GLOBAL=$P(GLOBAL,"(")     ;strip off parens
  1.  . S NAME=$P($P(^DIC(FILE,0),U),"V ",2)_"S"
  1.  . ;
  1.  . S IEN=0 F  S IEN=$O(@GLOBAL@("AD",V,IEN)) Q:'IEN  D
  1.  .. S ARRAY(NAME)=$G(ARRAY(NAME))+1
  1.  Q
  1.  ;
  1. SET(DATA,NUM,CNT,IEN) ; put display line into array
  1.  S NUM=NUM+1
  1.  S ^TMP("BDGPCCE2",$J,NUM,0)=DATA
  1.  S ^TMP("BDGPCCE2",$J,"IDX",NUM,CNT)=IEN
  1.  Q
  1.  ;
  1. EDITCAT ;EP; called by Edit Service Category protocol
  1.  NEW BDGN,DIE,DA,DR,AUPNVSIT
  1.  D GETVST I 'BDGN S VALMBCK="R" Q
  1.  S DIE="^AUPNVSIT(",DA=BDGN,DR=".07" D ^DIE
  1.  S AUPNVSIT=BDGN D MOD^AUPNVSIT
  1.  D RESET
  1.  Q
  1.  ;
  1. EDITVST ;EP; called by Edit Visit protocol
  1.  NEW APCDVSIT,APCDPAT,BDGN
  1.  D GETVST I 'BDGN S VALMBCK="R" Q
  1.  S APCDPAT=DFN,APCDVSIT=BDGN
  1.  D EN^APCDEL,^APCDEKL,RESET
  1.  Q
  1.  ;
  1. VIEWVST ;EP; called by View Visit protocol
  1.  NEW BDGN,APCDPAT,APCDVSIT
  1.  D GETVST I 'BDGN S VALMBCK="R" Q
  1.  S APCDPAT=DFN,APCDVSIT=BDGN
  1.  D ^APCDVD                      ;public entry point
  1.  D EN^XBVK("APCD") S VALMBCK="R"
  1.  Q
  1.  Q
  1.  ;
  1. RESET ;EP; return from protocol & rebuild list
  1.  S VALMBCK="R" D TERM^VALM0,HDR,INIT Q
  1.  ;
  1. HELP ; -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXIT ; -- exit code
  1.  K ^TMP("BDGPCCE2",$J)
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  1.  Q
  1.  ;
  1. GETVST ;  select visit from list
  1.  ; returns BDGN
  1.  NEW X,Y,Z
  1.  S BDGN=0 D FULL^VALM1
  1.  D EN^VALM2(XQORNOD(0),"OS")
  1.  I '$D(VALMY) Q
  1.  S X=0 F  S X=$O(VALMY(X)) Q:X=""  D
  1.  . S Y=0 F  S Y=$O(^TMP("BDGPCCE2",$J,"IDX",Y)) Q:Y=""  D
  1.  .. S Z=$O(^TMP("BDGPCCE2",$J,"IDX",Y,0))
  1.  .. Q:^TMP("BDGPCCE2",$J,"IDX",Y,Z)=""
  1.  .. I Z=X S BDGN=^TMP("BDGPCCE2",$J,"IDX",Y,Z)
  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)