RA27PST ;HIRMFO/SWM - Clean up after Patch RA*5.0*27 ;12/28/01 14:06
VERSION ;;5.0;Radiology/Nuclear Medicine;**27**;Mar 16, 1998
; *** Delete duplicate Clinical History from file #74 ***
;
QOFF ;Post-Install queues off clean-up job
I '$D(XPDNM)#2 W !!,"** This entry point must be called from KIDS installation **",!! Q
N RATXT,ZTDESC,ZTDTH,ZTIO,ZTRTN S ZTIO=""
S ZTRTN="EN^RA27PST"
S ZTDESC="RA*5.0*27 Cleanup Duplicate Clin. Hist. from File 74"
S ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT(),0,0,2,0) ;add 2 minutes to 'now'
D ^%ZTLOAD S RATXT(1)=" "
S RATXT(2)="RA*5.0*27 cleanup is running in background."
S:$G(ZTSK)>0 RATXT(3)="Task: "_ZTSK_"." D MES^XPDUTL(.RATXT)
Q
MANUAL ;manually queue off clean-up job, only needed if post-install abends
;^XTMP("RA-RA27PST",0)=60days later^date+time this was 1st run^description^subsequent date+time this was run (overwritten each subsequent time)
I +$G(DUZ)=0 W !!?5,"** DUZ is required! Nothing done. **",!! Q
N RA1 S RA1=""
I $D(^XTMP("RA-RA27PST",0))#2 S RA1=^(0)
I RA1="" W !,"This clean-up was either never queued off by the Installation of RA*5.0*27,",!,"or it had been completed over 60 days ago.",!! G ASKQ
I $P(RA1,"^",4)]"" S Y=$P(RA1,"^",4) D DD^%DT W !!?2,"MANUAL^RA27PST was done previously on ",Y,!!
I $P(RA1,"^",4)="" S Y=$P(RA1,"^",2) D DD^%DT W !!?2,"The installation of RA*5*27 tasked this job on ",Y,!?2,"but the job abended.",!!
I $G(^XTMP("RA-RA27PST","LAST"))="DONE" W !,"This clean-up was completed. You do not have to queue it again.",!! Q
ASKQ K DIR,DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="Y",DIR("B")="No"
S DIR("?")="Enter 'Y' if you want to queue the clean-up of duplicate Clin. History for File #74."
S DIR("A")="Do you want to continue the clean-up from patch RA*5.0*27"
D ^DIR
K DIR,DIROUT,DIRUT,DTOUT,DUOUT
Q:'Y ;don't queue if answer is NO
N ZTDESC,ZTDTH,ZTIO,ZTRTN S ZTIO=""
S ZTRTN="EN^RA27PST"
S ZTDESC="MANUAL Cleanup Duplicate Clin. Hist. from File 74, (RA*5*27 post-install)"
S ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT(),0,0,2,0) ;add 2 minutes to 'now'
D ^%ZTLOAD
W !?2,"RA*5.0*27 cleanup will start in 2 minutes in the background."
I $G(ZTSK)>0 W !?2,"Task: "_ZTSK_".",!!
Q
;
EN ; delete duplicate clinical history from file 74
S ZTREQ="@" ; delete from the task global
N %,RA70,RA701,RA74,RACNT,RAD0,RADFN,RADTI,RADELCNT,RADUPCNT
N RACNI,RACN,RACNT,RADUPHX,RANODE,RAOK,RAPOINT,RAX,RAX1
N RA1,RA2,RA3
S RA1="To IRM staff:"
S RA2=" If this routine abends, you may get the current count"
S RA3=" of records processed by listing ^XTMP(""RA-RA27PST"" "
S ^XTMP("RA-RA27PST",.1)=" Here are the counts from the post-install cleanup."
S ^XTMP("RA-RA27PST",.2)=" "
D INIT
I RAPOINT="DONE" S ^XTMP("RA-RA27PST",.1)="Already done previously. No need to continue.",^(.3)="----- Previous results are repeated below: ----- ",^(.4)="" D MAIL Q
S RAD0=+RAPOINT
F S RAD0=$O(^RARPT(RAD0)) Q:'RAD0 D CHKHX D:RADUPHX DELHX S ^XTMP("RA-RA27PST","LAST")=RAD0,RACNT=RACNT+1,$P(^XTMP("RA-RA27PST",.5),"^")=RACNT
; increment "LAST" and RACNT after chkhx and delhx
D FINISH
D MAIL
Q
CHKHX ; Check History between file 70 and 74.
; Returns RADUPHX 1 = Duplicate
; 0 = Different
S RADUPHX=0
I '$O(^RARPT(RAD0,"H",0)) Q ;default to 0 to skip DELHX since no data
S RANODE=$G(^RARPT(RAD0,0)) Q:RANODE=""
S RADFN=$P(RANODE,"^",2),RADTI=9999999.9999-$P(RANODE,"^",3)
S RACN=$P(RANODE,"^",4)
Q:'RADFN!('RADTI)!('RACN)
S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0))
Q:'RACNI
S RA74=$O(^RARPT(RAD0,"H",""),-1)
S RA70=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",""),-1),RA701=$O(^(0))
Q:RA70=0 Q:RA701="" ;no history in exam record
S RAX=RA74-RA70+1 Q:RAX'=1 ;different total lines
; same total lines, so check line by line
; RAOK=1 all lines match, =0 at least 1 difference
S RAOK=1
F RAX1=RA701:1:RA70 I ^RARPT(RAD0,"H",RAX1,0)'=^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAX1,0) S RAOK=0 Q
I 'RAOK Q
S RADUPCNT=RADUPCNT+1
S $P(^XTMP("RA-RA27PST",.6),"^")=RADUPCNT
I $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",17)'=RAD0 D MSG1 Q ;exam not pointing to this report, so skip this report
S RADUPHX=1
Q
DELHX ; delete history portion from this report
L +^RARPT(RAD0):0 I '$T D MSG2 Q
K ^RARPT(RAD0,"H")
L -^RARPT(RAD0)
S RADELCNT=RADELCNT+1
S $P(^XTMP("RA-RA27PST",.7),"^")=RADELCNT
Q
MSG1 ;
S ^XTMP("RA-RA27PST",RAD0)=$P(RANODE,"^")_" ien="_RAD0_" but",^XTMP("RA-RA27PST",(RAD0+.1))=" ^RADPT("_RADFN_",""DT"","_RADTI_",""P"","_RACNI_",0)'s 17th piece="_$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",17)
Q
MSG2 ;
S ^XTMP("RA-RA27PST",RAD0)=$P(RANODE,"^")_" locked by another process."
Q
INIT ; set point of latest ien processed
N %,%H,%I,%T,X,Y,RANOW
D NOW^%DTC S RANOW=% ;output NOW's dt+tm is in var %
I $D(^XTMP("RA-RA27PST",0))#2 S $P(^(0),"^",4)=RANOW,RAPOINT=^("LAST"),RACNT=+^(.5),RADUPCNT=+^(.6),RADELCNT=+^(.7) Q
S (RACNT,RADELCNT,RADUPCNT,RAPOINT)=0
S X1=RANOW,X2=60 D C^%DTC ;add 60 days to RANOW, output is X
S ^XTMP("RA-RA27PST",0)=X_"^"_RANOW_"^"_"RA*5*27 POST-INSTALL"
S ^XTMP("RA-RA27PST","LAST")=0
S ^XTMP("RA-RA27PST",.5)="^ reports processed"
S ^XTMP("RA-RA27PST",.6)="^ reports with dupl history"
S ^XTMP("RA-RA27PST",.7)="^ reports had dupl history purged"
Q
FINISH ; all done
S ^XTMP("RA-RA27PST","LAST")="DONE"
S ^XTMP("RA-RA27PST",.8)=" "
S ^XTMP("RA-RA27PST",.81)=" The cleanup finished."
S ^XTMP("RA-RA27PST",.82)=" "
I $O(^XTMP("RA-RA27PST",.99)) S ^XTMP("RA-RA27PST",.83)="The following reports' history was not purged:",^(.84)=" "
Q
MAIL ; Send mail message to the installer
N XMDUZ,XMSUB,XMTEXT,XMY S XMDUZ=.5
S XMTEXT="^XTMP(""RA-RA27PST""," ;only numeric nodes are mailed
S XMSUB="Results from patch RA*5*27's post-install rtn RA27PST"
S XMY(DUZ)="" D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRA27PST 5874 printed Sep 23, 2025@20:09:14 Page 2
RA27PST ;HIRMFO/SWM - Clean up after Patch RA*5.0*27 ;12/28/01 14:06
VERSION ;;5.0;Radiology/Nuclear Medicine;**27**;Mar 16, 1998
+1 ; *** Delete duplicate Clinical History from file #74 ***
+2 ;
QOFF ;Post-Install queues off clean-up job
+1 IF '$DATA(XPDNM)#2
WRITE !!,"** This entry point must be called from KIDS installation **",!!
QUIT
+2 NEW RATXT,ZTDESC,ZTDTH,ZTIO,ZTRTN
SET ZTIO=""
+3 SET ZTRTN="EN^RA27PST"
+4 SET ZTDESC="RA*5.0*27 Cleanup Duplicate Clin. Hist. from File 74"
+5 ;add 2 minutes to 'now'
SET ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT(),0,0,2,0)
+6 DO ^%ZTLOAD
SET RATXT(1)=" "
+7 SET RATXT(2)="RA*5.0*27 cleanup is running in background."
+8 if $GET(ZTSK)>0
SET RATXT(3)="Task: "_ZTSK_"."
DO MES^XPDUTL(.RATXT)
+9 QUIT
MANUAL ;manually queue off clean-up job, only needed if post-install abends
+1 ;^XTMP("RA-RA27PST",0)=60days later^date+time this was 1st run^description^subsequent date+time this was run (overwritten each subsequent time)
+2 IF +$GET(DUZ)=0
WRITE !!?5,"** DUZ is required! Nothing done. **",!!
QUIT
+3 NEW RA1
SET RA1=""
+4 IF $DATA(^XTMP("RA-RA27PST",0))#2
SET RA1=^(0)
+5 IF RA1=""
WRITE !,"This clean-up was either never queued off by the Installation of RA*5.0*27,",!,"or it had been completed over 60 days ago.",!!
GOTO ASKQ
+6 IF $PIECE(RA1,"^",4)]""
SET Y=$PIECE(RA1,"^",4)
DO DD^%DT
WRITE !!?2,"MANUAL^RA27PST was done previously on ",Y,!!
+7 IF $PIECE(RA1,"^",4)=""
SET Y=$PIECE(RA1,"^",2)
DO DD^%DT
WRITE !!?2,"The installation of RA*5*27 tasked this job on ",Y,!?2,"but the job abended.",!!
+8 IF $GET(^XTMP("RA-RA27PST","LAST"))="DONE"
WRITE !,"This clean-up was completed. You do not have to queue it again.",!!
QUIT
ASKQ KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
+1 SET DIR(0)="Y"
SET DIR("B")="No"
+2 SET DIR("?")="Enter 'Y' if you want to queue the clean-up of duplicate Clin. History for File #74."
+3 SET DIR("A")="Do you want to continue the clean-up from patch RA*5.0*27"
+4 DO ^DIR
+5 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
+6 ;don't queue if answer is NO
if 'Y
QUIT
+7 NEW ZTDESC,ZTDTH,ZTIO,ZTRTN
SET ZTIO=""
+8 SET ZTRTN="EN^RA27PST"
+9 SET ZTDESC="MANUAL Cleanup Duplicate Clin. Hist. from File 74, (RA*5*27 post-install)"
+10 ;add 2 minutes to 'now'
SET ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT(),0,0,2,0)
+11 DO ^%ZTLOAD
+12 WRITE !?2,"RA*5.0*27 cleanup will start in 2 minutes in the background."
+13 IF $GET(ZTSK)>0
WRITE !?2,"Task: "_ZTSK_".",!!
+14 QUIT
+15 ;
EN ; delete duplicate clinical history from file 74
+1 ; delete from the task global
SET ZTREQ="@"
+2 NEW %,RA70,RA701,RA74,RACNT,RAD0,RADFN,RADTI,RADELCNT,RADUPCNT
+3 NEW RACNI,RACN,RACNT,RADUPHX,RANODE,RAOK,RAPOINT,RAX,RAX1
+4 NEW RA1,RA2,RA3
+5 SET RA1="To IRM staff:"
+6 SET RA2=" If this routine abends, you may get the current count"
+7 SET RA3=" of records processed by listing ^XTMP(""RA-RA27PST"" "
+8 SET ^XTMP("RA-RA27PST",.1)=" Here are the counts from the post-install cleanup."
+9 SET ^XTMP("RA-RA27PST",.2)=" "
+10 DO INIT
+11 IF RAPOINT="DONE"
SET ^XTMP("RA-RA27PST",.1)="Already done previously. No need to continue."
SET ^(.3)="----- Previous results are repeated below: ----- "
SET ^(.4)=""
DO MAIL
QUIT
+12 SET RAD0=+RAPOINT
+13 FOR
SET RAD0=$ORDER(^RARPT(RAD0))
if 'RAD0
QUIT
DO CHKHX
if RADUPHX
DO DELHX
SET ^XTMP("RA-RA27PST","LAST")=RAD0
SET RACNT=RACNT+1
SET $PIECE(^XTMP("RA-RA27PST",.5),"^")=RACNT
+14 ; increment "LAST" and RACNT after chkhx and delhx
+15 DO FINISH
+16 DO MAIL
+17 QUIT
CHKHX ; Check History between file 70 and 74.
+1 ; Returns RADUPHX 1 = Duplicate
+2 ; 0 = Different
+3 SET RADUPHX=0
+4 ;default to 0 to skip DELHX since no data
IF '$ORDER(^RARPT(RAD0,"H",0))
QUIT
+5 SET RANODE=$GET(^RARPT(RAD0,0))
if RANODE=""
QUIT
+6 SET RADFN=$PIECE(RANODE,"^",2)
SET RADTI=9999999.9999-$PIECE(RANODE,"^",3)
+7 SET RACN=$PIECE(RANODE,"^",4)
+8 if 'RADFN!('RADTI)!('RACN)
QUIT
+9 SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0))
+10 if 'RACNI
QUIT
+11 SET RA74=$ORDER(^RARPT(RAD0,"H",""),-1)
+12 SET RA70=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",""),-1)
SET RA701=$ORDER(^(0))
+13 ;no history in exam record
if RA70=0
QUIT
if RA701=""
QUIT
+14 ;different total lines
SET RAX=RA74-RA70+1
if RAX'=1
QUIT
+15 ; same total lines, so check line by line
+16 ; RAOK=1 all lines match, =0 at least 1 difference
+17 SET RAOK=1
+18 FOR RAX1=RA701:1:RA70
IF ^RARPT(RAD0,"H",RAX1,0)'=^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAX1,0)
SET RAOK=0
QUIT
+19 IF 'RAOK
QUIT
+20 SET RADUPCNT=RADUPCNT+1
+21 SET $PIECE(^XTMP("RA-RA27PST",.6),"^")=RADUPCNT
+22 ;exam not pointing to this report, so skip this report
IF $PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",17)'=RAD0
DO MSG1
QUIT
+23 SET RADUPHX=1
+24 QUIT
DELHX ; delete history portion from this report
+1 LOCK +^RARPT(RAD0):0
IF '$TEST
DO MSG2
QUIT
+2 KILL ^RARPT(RAD0,"H")
+3 LOCK -^RARPT(RAD0)
+4 SET RADELCNT=RADELCNT+1
+5 SET $PIECE(^XTMP("RA-RA27PST",.7),"^")=RADELCNT
+6 QUIT
MSG1 ;
+1 SET ^XTMP("RA-RA27PST",RAD0)=$PIECE(RANODE,"^")_" ien="_RAD0_" but"
SET ^XTMP("RA-RA27PST",(RAD0+.1))=" ^RADPT("_RADFN_",""DT"","_RADTI_",""P"","_RACNI_",0)'s 17th piece="_$PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",17)
+2 QUIT
MSG2 ;
+1 SET ^XTMP("RA-RA27PST",RAD0)=$PIECE(RANODE,"^")_" locked by another process."
+2 QUIT
INIT ; set point of latest ien processed
+1 NEW %,%H,%I,%T,X,Y,RANOW
+2 ;output NOW's dt+tm is in var %
DO NOW^%DTC
SET RANOW=%
+3 IF $DATA(^XTMP("RA-RA27PST",0))#2
SET $PIECE(^(0),"^",4)=RANOW
SET RAPOINT=^("LAST")
SET RACNT=+^(.5)
SET RADUPCNT=+^(.6)
SET RADELCNT=+^(.7)
QUIT
+4 SET (RACNT,RADELCNT,RADUPCNT,RAPOINT)=0
+5 ;add 60 days to RANOW, output is X
SET X1=RANOW
SET X2=60
DO C^%DTC
+6 SET ^XTMP("RA-RA27PST",0)=X_"^"_RANOW_"^"_"RA*5*27 POST-INSTALL"
+7 SET ^XTMP("RA-RA27PST","LAST")=0
+8 SET ^XTMP("RA-RA27PST",.5)="^ reports processed"
+9 SET ^XTMP("RA-RA27PST",.6)="^ reports with dupl history"
+10 SET ^XTMP("RA-RA27PST",.7)="^ reports had dupl history purged"
+11 QUIT
FINISH ; all done
+1 SET ^XTMP("RA-RA27PST","LAST")="DONE"
+2 SET ^XTMP("RA-RA27PST",.8)=" "
+3 SET ^XTMP("RA-RA27PST",.81)=" The cleanup finished."
+4 SET ^XTMP("RA-RA27PST",.82)=" "
+5 IF $ORDER(^XTMP("RA-RA27PST",.99))
SET ^XTMP("RA-RA27PST",.83)="The following reports' history was not purged:"
SET ^(.84)=" "
+6 QUIT
MAIL ; Send mail message to the installer
+1 NEW XMDUZ,XMSUB,XMTEXT,XMY
SET XMDUZ=.5
+2 ;only numeric nodes are mailed
SET XMTEXT="^XTMP(""RA-RA27PST"","
+3 SET XMSUB="Results from patch RA*5*27's post-install rtn RA27PST"
+4 SET XMY(DUZ)=""
DO ^XMD
+5 QUIT
