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

TIUPS120.m

Go to the documentation of this file. 
  1. TIUPS120 ; SLC/JER - Post-install for TIU*1*120 ; 12-JUL-2001 10:59
  1.  ;;1.0;TEXT INTEGRATION UTILITIES;**120**;Jun 20, 1997
  1. MAIN ; Control Subroutine
  1.  N TIUDAD,TIUCNT,TIUIDT,XPDIDTOT,XPDIDVT S TIUCNT=0,TIUDT=""
  1.  S XPDIDVT=+$G(XPDIDVT)
  1.  D BMES^XPDUTL(" ** FINDING DISCHARGE SUMMARIES THAT SHOULD BE ADDENDA **")
  1.  S ^XTMP("TIUPS120",0)=$$FMADD^XLFDT(DT,90)_U_DT
  1.  S TIUIDT=$$GETSTART
  1.  D GATHER(TIUIDT)
  1.  I '+$O(^XTMP("TIUPS120","DSLIST",0)) D BMES^XPDUTL(" No Aberrant Summaries Found...") Q
  1.  S XPDIDTOT=$P(^XTMP("TIUPS120","DSLIST",0),U),XPDIDVT=+$G(XPDIDVT)
  1.  D UPDATE^XPDID(0)
  1.  S TIUDAD=0
  1.  F  S TIUDAD=$O(^XTMP("TIUPS120","DSLIST",TIUDAD)) Q:+TIUDAD'>0  D
  1.  . N TIUDA S TIUDA=0
  1.  . F  S TIUDA=$O(^XTMP("TIUPS120","DSLIST",TIUDAD,TIUDA)) Q:+TIUDA'>0  D
  1.  . . D FIX(TIUDAD,TIUDA) S TIUCNT=TIUCNT+1
  1.  . . I '(TIUCNT#10) D UPDATE^XPDID(TIUCNT)
  1.  Q
  1. GATHER(TIUIDT) ; Fetch list of summaries to fix
  1.  N TIUDT S TIUDT=""
  1.  F  S TIUDT=$O(^TIU(8925,"F",TIUDT),-1) Q:TIUDT<TIUIDT!'+TIUDT  D
  1.  . N TIUDA S TIUDA=""
  1.  . F  S TIUDA=$O(^TIU(8925,"F",TIUDT,TIUDA),-1) Q:+TIUDA'>0  D
  1.  . . N TIUD0 S TIUD0=$G(^TIU(8925,TIUDA,0))
  1.  . . ; Only process discharge summaries
  1.  . . Q:+$$ISDS^TIULX(+TIUD0)'>0
  1.  . . ; Add cases where >1 summary is entered for the Admission
  1.  . . D ADDLIST(TIUDA)
  1.  . S ^XTMP("TIUPS120","CHKPNT")=TIUDT
  1.  Q
  1. ADDLIST(TIUDA) ; If Multiple Discharge Summaries are present, add to list
  1.  N TIUD0,TIUD12,TIUVSTR,TIUDA1,TIUD01,TIUCNT,COUNT
  1.  S TIUD0=$G(^TIU(8925,TIUDA,0)),TIUD12=$G(^(12))
  1.  S TIUVSTR=$P(TIUD12,U,11)_";"_$P(TIUD0,U,7)_";"_$P(TIUD0,U,13)
  1.  ; Only include cases where >1 summary exists for a Hospitalization
  1.  S COUNT=+$$COUNT(+$P(TIUD0,U,2),+TIUD0,TIUVSTR)
  1.  Q:COUNT'>1
  1.  ; Get the first record in for the pt. and admission in question
  1.  S TIUCNT=0,TIUDA1=""
  1.  F  S TIUDA1=$O(^TIU(8925,"APTLD",+$P(TIUD0,U,2),+TIUD0,TIUVSTR,TIUDA1))  Q:+TIUDA1'>0  D
  1.  . N TIUD01 S TIUD01=$G(^TIU(8925,TIUDA1,0))
  1.  . ; Omit documents that have been deleted or retracted...
  1.  . I +$P(TIUD01,U,5)>13 Q
  1.  . S TIUCNT=TIUCNT+1
  1.  . I TIUCNT=1 S TIUDAD=TIUDA1
  1.  . I TIUDAD'=TIUDA1,'$D(^XTMP("TIUPS120","DSLIST",TIUDAD,TIUDA1)) D
  1.  . . S ^XTMP("TIUPS120","DSLIST",TIUDAD,TIUDA1)=""
  1.  . . S ^XTMP("TIUPS120","DSLIST",0)=+$G(^XTMP("TIUPS120","DSLIST",0))+1
  1.  Q
  1. COUNT(DFN,TTL,VSTR) ; How many are there
  1.  N TIUY,TIUDA S (TIUDA,TIUY)=0
  1.  F  S TIUDA=$O(^TIU(8925,"APTLD",DFN,+TTL,VSTR,TIUDA)) Q:+TIUDA'>0  D
  1.  . N TIUD0 S TIUD0=$G(^TIU(8925,TIUDA,0))
  1.  . ; Omit RETRACTED or DELETED records
  1.  . Q:+$P(TIUD0,U,5)>13
  1.  . S TIUY=TIUY+1
  1.  Q TIUY
  1. FIX(TIUDAD,TIUDA) ; Make TIUDA an addendum of TIUDAD
  1.  N DA,DIE,DR
  1.  S DIE=8925,DA=TIUDA,DR=".01////^S X=81;.06////^S X=TIUDAD"
  1.  D ^DIE
  1.  Q
  1. GETSTART() ; Find out when Patch TIU*1*100 was installed
  1.  N INSTDA,TIUY S INSTDA=""
  1.  S TIUY=+$G(^XTMP("TIUPS120","CHKPNT"))
  1.  I +TIUY>0 G GETSTX
  1.  S INSTDA=$O(^XPD(9.7,"B","TIU*1.0*100",INSTDA),-1)
  1.  S TIUY=+$P($G(^XPD(9.7,INSTDA,1)),U,3)
  1. GETSTX Q TIUY