TIUPS120 ; SLC/JER - Post-install for TIU*1*120 ; 12-JUL-2001 10:59
;;1.0;TEXT INTEGRATION UTILITIES;**120**;Jun 20, 1997
MAIN ; Control Subroutine
N TIUDAD,TIUCNT,TIUIDT,XPDIDTOT,XPDIDVT S TIUCNT=0,TIUDT=""
S XPDIDVT=+$G(XPDIDVT)
D BMES^XPDUTL(" ** FINDING DISCHARGE SUMMARIES THAT SHOULD BE ADDENDA **")
S ^XTMP("TIUPS120",0)=$$FMADD^XLFDT(DT,90)_U_DT
S TIUIDT=$$GETSTART
D GATHER(TIUIDT)
I '+$O(^XTMP("TIUPS120","DSLIST",0)) D BMES^XPDUTL(" No Aberrant Summaries Found...") Q
S XPDIDTOT=$P(^XTMP("TIUPS120","DSLIST",0),U),XPDIDVT=+$G(XPDIDVT)
D UPDATE^XPDID(0)
S TIUDAD=0
F S TIUDAD=$O(^XTMP("TIUPS120","DSLIST",TIUDAD)) Q:+TIUDAD'>0 D
. N TIUDA S TIUDA=0
. F S TIUDA=$O(^XTMP("TIUPS120","DSLIST",TIUDAD,TIUDA)) Q:+TIUDA'>0 D
. . D FIX(TIUDAD,TIUDA) S TIUCNT=TIUCNT+1
. . I '(TIUCNT#10) D UPDATE^XPDID(TIUCNT)
Q
GATHER(TIUIDT) ; Fetch list of summaries to fix
N TIUDT S TIUDT=""
F S TIUDT=$O(^TIU(8925,"F",TIUDT),-1) Q:TIUDT<TIUIDT!'+TIUDT D
. N TIUDA S TIUDA=""
. F S TIUDA=$O(^TIU(8925,"F",TIUDT,TIUDA),-1) Q:+TIUDA'>0 D
. . N TIUD0 S TIUD0=$G(^TIU(8925,TIUDA,0))
. . ; Only process discharge summaries
. . Q:+$$ISDS^TIULX(+TIUD0)'>0
. . ; Add cases where >1 summary is entered for the Admission
. . D ADDLIST(TIUDA)
. S ^XTMP("TIUPS120","CHKPNT")=TIUDT
Q
ADDLIST(TIUDA) ; If Multiple Discharge Summaries are present, add to list
N TIUD0,TIUD12,TIUVSTR,TIUDA1,TIUD01,TIUCNT,COUNT
S TIUD0=$G(^TIU(8925,TIUDA,0)),TIUD12=$G(^(12))
S TIUVSTR=$P(TIUD12,U,11)_";"_$P(TIUD0,U,7)_";"_$P(TIUD0,U,13)
; Only include cases where >1 summary exists for a Hospitalization
S COUNT=+$$COUNT(+$P(TIUD0,U,2),+TIUD0,TIUVSTR)
Q:COUNT'>1
; Get the first record in for the pt. and admission in question
S TIUCNT=0,TIUDA1=""
F S TIUDA1=$O(^TIU(8925,"APTLD",+$P(TIUD0,U,2),+TIUD0,TIUVSTR,TIUDA1)) Q:+TIUDA1'>0 D
. N TIUD01 S TIUD01=$G(^TIU(8925,TIUDA1,0))
. ; Omit documents that have been deleted or retracted...
. I +$P(TIUD01,U,5)>13 Q
. S TIUCNT=TIUCNT+1
. I TIUCNT=1 S TIUDAD=TIUDA1
. I TIUDAD'=TIUDA1,'$D(^XTMP("TIUPS120","DSLIST",TIUDAD,TIUDA1)) D
. . S ^XTMP("TIUPS120","DSLIST",TIUDAD,TIUDA1)=""
. . S ^XTMP("TIUPS120","DSLIST",0)=+$G(^XTMP("TIUPS120","DSLIST",0))+1
Q
COUNT(DFN,TTL,VSTR) ; How many are there
N TIUY,TIUDA S (TIUDA,TIUY)=0
F S TIUDA=$O(^TIU(8925,"APTLD",DFN,+TTL,VSTR,TIUDA)) Q:+TIUDA'>0 D
. N TIUD0 S TIUD0=$G(^TIU(8925,TIUDA,0))
. ; Omit RETRACTED or DELETED records
. Q:+$P(TIUD0,U,5)>13
. S TIUY=TIUY+1
Q TIUY
FIX(TIUDAD,TIUDA) ; Make TIUDA an addendum of TIUDAD
N DA,DIE,DR
S DIE=8925,DA=TIUDA,DR=".01////^S X=81;.06////^S X=TIUDAD"
D ^DIE
Q
GETSTART() ; Find out when Patch TIU*1*100 was installed
N INSTDA,TIUY S INSTDA=""
S TIUY=+$G(^XTMP("TIUPS120","CHKPNT"))
I +TIUY>0 G GETSTX
S INSTDA=$O(^XPD(9.7,"B","TIU*1.0*100",INSTDA),-1)
S TIUY=+$P($G(^XPD(9.7,INSTDA,1)),U,3)
GETSTX Q TIUY
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUPS120 2944 printed Nov 22, 2024@17:53:55 Page 2
TIUPS120 ; SLC/JER - Post-install for TIU*1*120 ; 12-JUL-2001 10:59
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**120**;Jun 20, 1997
MAIN ; Control Subroutine
+1 NEW TIUDAD,TIUCNT,TIUIDT,XPDIDTOT,XPDIDVT
SET TIUCNT=0
SET TIUDT=""
+2 SET XPDIDVT=+$GET(XPDIDVT)
+3 DO BMES^XPDUTL(" ** FINDING DISCHARGE SUMMARIES THAT SHOULD BE ADDENDA **")
+4 SET ^XTMP("TIUPS120",0)=$$FMADD^XLFDT(DT,90)_U_DT
+5 SET TIUIDT=$$GETSTART
+6 DO GATHER(TIUIDT)
+7 IF '+$ORDER(^XTMP("TIUPS120","DSLIST",0))
DO BMES^XPDUTL(" No Aberrant Summaries Found...")
QUIT
+8 SET XPDIDTOT=$PIECE(^XTMP("TIUPS120","DSLIST",0),U)
SET XPDIDVT=+$GET(XPDIDVT)
+9 DO UPDATE^XPDID(0)
+10 SET TIUDAD=0
+11 FOR
SET TIUDAD=$ORDER(^XTMP("TIUPS120","DSLIST",TIUDAD))
if +TIUDAD'>0
QUIT
Begin DoDot:1
+12 NEW TIUDA
SET TIUDA=0
+13 FOR
SET TIUDA=$ORDER(^XTMP("TIUPS120","DSLIST",TIUDAD,TIUDA))
if +TIUDA'>0
QUIT
Begin DoDot:2
+14 DO FIX(TIUDAD,TIUDA)
SET TIUCNT=TIUCNT+1
+15 IF '(TIUCNT#10)
DO UPDATE^XPDID(TIUCNT)
End DoDot:2
End DoDot:1
+16 QUIT
GATHER(TIUIDT) ; Fetch list of summaries to fix
+1 NEW TIUDT
SET TIUDT=""
+2 FOR
SET TIUDT=$ORDER(^TIU(8925,"F",TIUDT),-1)
if TIUDT<TIUIDT!'+TIUDT
QUIT
Begin DoDot:1
+3 NEW TIUDA
SET TIUDA=""
+4 FOR
SET TIUDA=$ORDER(^TIU(8925,"F",TIUDT,TIUDA),-1)
if +TIUDA'>0
QUIT
Begin DoDot:2
+5 NEW TIUD0
SET TIUD0=$GET(^TIU(8925,TIUDA,0))
+6 ; Only process discharge summaries
+7 if +$$ISDS^TIULX(+TIUD0)'>0
QUIT
+8 ; Add cases where >1 summary is entered for the Admission
+9 DO ADDLIST(TIUDA)
End DoDot:2
+10 SET ^XTMP("TIUPS120","CHKPNT")=TIUDT
End DoDot:1
+11 QUIT
ADDLIST(TIUDA) ; If Multiple Discharge Summaries are present, add to list
+1 NEW TIUD0,TIUD12,TIUVSTR,TIUDA1,TIUD01,TIUCNT,COUNT
+2 SET TIUD0=$GET(^TIU(8925,TIUDA,0))
SET TIUD12=$GET(^(12))
+3 SET TIUVSTR=$PIECE(TIUD12,U,11)_";"_$PIECE(TIUD0,U,7)_";"_$PIECE(TIUD0,U,13)
+4 ; Only include cases where >1 summary exists for a Hospitalization
+5 SET COUNT=+$$COUNT(+$PIECE(TIUD0,U,2),+TIUD0,TIUVSTR)
+6 if COUNT'>1
QUIT
+7 ; Get the first record in for the pt. and admission in question
+8 SET TIUCNT=0
SET TIUDA1=""
+9 FOR
SET TIUDA1=$ORDER(^TIU(8925,"APTLD",+$PIECE(TIUD0,U,2),+TIUD0,TIUVSTR,TIUDA1))
if +TIUDA1'>0
QUIT
Begin DoDot:1
+10 NEW TIUD01
SET TIUD01=$GET(^TIU(8925,TIUDA1,0))
+11 ; Omit documents that have been deleted or retracted...
+12 IF +$PIECE(TIUD01,U,5)>13
QUIT
+13 SET TIUCNT=TIUCNT+1
+14 IF TIUCNT=1
SET TIUDAD=TIUDA1
+15 IF TIUDAD'=TIUDA1
IF '$DATA(^XTMP("TIUPS120","DSLIST",TIUDAD,TIUDA1))
Begin DoDot:2
+16 SET ^XTMP("TIUPS120","DSLIST",TIUDAD,TIUDA1)=""
+17 SET ^XTMP("TIUPS120","DSLIST",0)=+$GET(^XTMP("TIUPS120","DSLIST",0))+1
End DoDot:2
End DoDot:1
+18 QUIT
COUNT(DFN,TTL,VSTR) ; How many are there
+1 NEW TIUY,TIUDA
SET (TIUDA,TIUY)=0
+2 FOR
SET TIUDA=$ORDER(^TIU(8925,"APTLD",DFN,+TTL,VSTR,TIUDA))
if +TIUDA'>0
QUIT
Begin DoDot:1
+3 NEW TIUD0
SET TIUD0=$GET(^TIU(8925,TIUDA,0))
+4 ; Omit RETRACTED or DELETED records
+5 if +$PIECE(TIUD0,U,5)>13
QUIT
+6 SET TIUY=TIUY+1
End DoDot:1
+7 QUIT TIUY
FIX(TIUDAD,TIUDA) ; Make TIUDA an addendum of TIUDAD
+1 NEW DA,DIE,DR
+2 SET DIE=8925
SET DA=TIUDA
SET DR=".01////^S X=81;.06////^S X=TIUDAD"
+3 DO ^DIE
+4 QUIT
GETSTART() ; Find out when Patch TIU*1*100 was installed
+1 NEW INSTDA,TIUY
SET INSTDA=""
+2 SET TIUY=+$GET(^XTMP("TIUPS120","CHKPNT"))
+3 IF +TIUY>0
GOTO GETSTX
+4 SET INSTDA=$ORDER(^XPD(9.7,"B","TIU*1.0*100",INSTDA),-1)
+5 SET TIUY=+$PIECE($GET(^XPD(9.7,INSTDA,1)),U,3)
GETSTX QUIT TIUY
