RA34PST ;HOIFO/SWM-Post install to correct entries in file 71 ;1/28/03 07:54
;;5.0;Radiology/Nuclear Medicine;**34**;Mar 16, 1998
QOFF ;Post-Install queues off File 71 Name correction job
I '$D(XPDNM)#2 D EN^DDIOL("This entry point must be called from the KIDS installation -- Nothing Done.",,"!!,$C(7)") Q
I +$G(DUZ)=0 D EN^DDIOL("DUZ isn't defined -- Nothing Done.",,"!!,$C(7)")
N RATXT,ZTDESC,ZTDTH,ZTIO,ZTRTN S ZTIO=""
S ZTRTN="EN^RA34PST"
S ZTDESC="RA*5.0*34 File 71 Name correction job"
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*34 File 71 Name correction is running in background."
S:$G(ZTSK)>0 RATXT(3)="Task: "_ZTSK_"."
S RATXT(4)=" "
S RATXT(5)="The results will be sent to your mailbox."
S RATXT(6)=" "
D MES^XPDUTL(.RATXT)
Q
MANUAL ;manually queue off Name correction job, only use if post-install abends
I +$G(DUZ)=0 D EN^DDIOL("DUZ isn't defined -- Nothing Done.",,"!!,$C(7)") Q
ASKQ K DIR,DIROUT,DIRUT,DTOUT,DUOUT
N RAX
S DIR(0)="Y",DIR("B")="No"
S DIR("?")="Enter 'Y' if you want to queue the File 71 Name correction job."
S DIR("A")="Do you want to start routine RA34PST to correct File 71 procedure names"
D ^DIR
K DIR,DIROUT,DIRUT,DTOUT,DUOUT
Q:'Y ;don't queue if answer is NO
D EN^DDIOL("The results will be sent to your mailmox.",,"!!,$C(7)")
N ZTDESC,ZTDTH,ZTIO,ZTRTN S ZTIO=""
S ZTRTN="EN^RA34PST"
S ZTDESC="MANUAL File 71 Name correction -- routine RA34PST"
S ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT(),0,0,2,0) ;add 2 minutes to 'now'
D ^%ZTLOAD
D EN^DDIOL("RA*5.0*34 File 71 Name correction will start in 2 minutes in the background.",,"!,$C(7)")
I $G(ZTSK)>0 S RAX="Task: "_ZTSK D EN^DDIOL(RAX,,"!,$C(7)")
Q
EN ; LOOP THRU FILE 71, FIELD .01
; remove SEMICOLON from it
; if proc is active, then call PROC^RAO7MFN to update OI file
N RAI,RAX,RA1,RA2,RA3,RAFDA,RASTAT,RAY,RACTOT,RAC1,RAC2,RABADTOT,RAC
S (RAI,RACTOT,RAC1,RAC2,RABADTOT,RAC)=0
SLOOP S RAI=$O(^RAMIS(71,RAI)) G:'RAI EXLOOP
S RAX=$G(^RAMIS(71,RAI,0)) G:RAX="" SLOOP
S RACTOT=RACTOT+1
S RA1=$P(RAX,"^")
I (RA1[";") D
. L +^RAMIS(71,RAI,0):0 I '$T D Q
.. S RA3="Can't lock ^RAMIS(71,"_RAI_",0), so "_RA1_" isn't changed."
.. D STOR
.. S RABADTOT=RABADTOT+1
.. Q
. S RA2=$TR(RA1,";",",") ; new string
. Q:$O(^RAMIS(71,"B",RA2,0)) ; skip if new string already exists
. S RA3="^RAMIS(71,"_RAI_",0)'s "_RA1_" will be "_RA2 D STOR
. D REMOV,CPRS
. L -^RAMIS(71,RAI,0)
. Q
G SLOOP
EXLOOP S RA3=" " D STOR
S RA3="File 71, RAD/NUC MED PROCEDURES, has been checked." D STOR
S RA3=" " D STOR
S RA3="No. records checked: "_$J(RACTOT,7) D STOR
S RA3="No. records had semicolon corrected: "_$J(RAC1,7) D STOR
S RA3="No. records updated in file 101.43: "_$J(RAC2,7) D STOR
S RA3="No. records locked and not updated: "_$J(RABADTOT,7) D STOR
D MAIL
S:$D(ZTQUEUED) ZTREQ="@"
Q
STOR ; store messages and totals
Q:$G(RA3)=""
S RAC=RAC+1,^TMP($J,"RA34PST",RAC)=RA3
Q
REMOV ; remove ";"
S RAC1=RAC1+1
S RAFDA(71,RAI_",",.01)=RA2
D FILE^DIE("E","RAFDA")
K RAFDA
Q
CPRS ; update record in Orderable Items file 101.43
Q:$$ORQUIK^RAORDU()'=1 ;skip update if no Order Dialog file 101.41
; skip if inactive
I $S('$D(^RAMIS(71,RAI,"I")):0,^("I")="":0,+^("I")>DT:0,1:1) Q
S RAC2=RAC2+1
S RASTAT="1^1"
S RAY=RAI_"^"_RA2
D PROC^RAO7MFN(0,71,RASTAT,RAY)
Q
MAIL ; Send mail message to the installer
N XMDUZ,XMSUB,XMTEXT,XMY S XMDUZ=.5
S XMTEXT="^TMP($J,""RA34PST""," ;only numeric nodes are mailed
S XMSUB="Results from routine RA34PST"
S XMY(DUZ)="" D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRA34PST 3675 printed Sep 23, 2025@20:09:16 Page 2
RA34PST ;HOIFO/SWM-Post install to correct entries in file 71 ;1/28/03 07:54
+1 ;;5.0;Radiology/Nuclear Medicine;**34**;Mar 16, 1998
QOFF ;Post-Install queues off File 71 Name correction job
+1 IF '$DATA(XPDNM)#2
DO EN^DDIOL("This entry point must be called from the KIDS installation -- Nothing Done.",,"!!,$C(7)")
QUIT
+2 IF +$GET(DUZ)=0
DO EN^DDIOL("DUZ isn't defined -- Nothing Done.",,"!!,$C(7)")
+3 NEW RATXT,ZTDESC,ZTDTH,ZTIO,ZTRTN
SET ZTIO=""
+4 SET ZTRTN="EN^RA34PST"
+5 SET ZTDESC="RA*5.0*34 File 71 Name correction job"
+6 ;add 2 minutes to 'now'
SET ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT(),0,0,2,0)
+7 DO ^%ZTLOAD
SET RATXT(1)=" "
+8 SET RATXT(2)="RA*5.0*34 File 71 Name correction is running in background."
+9 if $GET(ZTSK)>0
SET RATXT(3)="Task: "_ZTSK_"."
+10 SET RATXT(4)=" "
+11 SET RATXT(5)="The results will be sent to your mailbox."
+12 SET RATXT(6)=" "
+13 DO MES^XPDUTL(.RATXT)
+14 QUIT
MANUAL ;manually queue off Name correction job, only use if post-install abends
+1 IF +$GET(DUZ)=0
DO EN^DDIOL("DUZ isn't defined -- Nothing Done.",,"!!,$C(7)")
QUIT
ASKQ KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
+1 NEW RAX
+2 SET DIR(0)="Y"
SET DIR("B")="No"
+3 SET DIR("?")="Enter 'Y' if you want to queue the File 71 Name correction job."
+4 SET DIR("A")="Do you want to start routine RA34PST to correct File 71 procedure names"
+5 DO ^DIR
+6 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
+7 ;don't queue if answer is NO
if 'Y
QUIT
+8 DO EN^DDIOL("The results will be sent to your mailmox.",,"!!,$C(7)")
+9 NEW ZTDESC,ZTDTH,ZTIO,ZTRTN
SET ZTIO=""
+10 SET ZTRTN="EN^RA34PST"
+11 SET ZTDESC="MANUAL File 71 Name correction -- routine RA34PST"
+12 ;add 2 minutes to 'now'
SET ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT(),0,0,2,0)
+13 DO ^%ZTLOAD
+14 DO EN^DDIOL("RA*5.0*34 File 71 Name correction will start in 2 minutes in the background.",,"!,$C(7)")
+15 IF $GET(ZTSK)>0
SET RAX="Task: "_ZTSK
DO EN^DDIOL(RAX,,"!,$C(7)")
+16 QUIT
EN ; LOOP THRU FILE 71, FIELD .01
+1 ; remove SEMICOLON from it
+2 ; if proc is active, then call PROC^RAO7MFN to update OI file
+3 NEW RAI,RAX,RA1,RA2,RA3,RAFDA,RASTAT,RAY,RACTOT,RAC1,RAC2,RABADTOT,RAC
+4 SET (RAI,RACTOT,RAC1,RAC2,RABADTOT,RAC)=0
SLOOP SET RAI=$ORDER(^RAMIS(71,RAI))
if 'RAI
GOTO EXLOOP
+1 SET RAX=$GET(^RAMIS(71,RAI,0))
if RAX=""
GOTO SLOOP
+2 SET RACTOT=RACTOT+1
+3 SET RA1=$PIECE(RAX,"^")
+4 IF (RA1[";")
Begin DoDot:1
+5 LOCK +^RAMIS(71,RAI,0):0
IF '$TEST
Begin DoDot:2
+6 SET RA3="Can't lock ^RAMIS(71,"_RAI_",0), so "_RA1_" isn't changed."
+7 DO STOR
+8 SET RABADTOT=RABADTOT+1
+9 QUIT
End DoDot:2
QUIT
+10 ; new string
SET RA2=$TRANSLATE(RA1,";",",")
+11 ; skip if new string already exists
if $ORDER(^RAMIS(71,"B",RA2,0))
QUIT
+12 SET RA3="^RAMIS(71,"_RAI_",0)'s "_RA1_" will be "_RA2
DO STOR
+13 DO REMOV
DO CPRS
+14 LOCK -^RAMIS(71,RAI,0)
+15 QUIT
End DoDot:1
+16 GOTO SLOOP
EXLOOP SET RA3=" "
DO STOR
+1 SET RA3="File 71, RAD/NUC MED PROCEDURES, has been checked."
DO STOR
+2 SET RA3=" "
DO STOR
+3 SET RA3="No. records checked: "_$JUSTIFY(RACTOT,7)
DO STOR
+4 SET RA3="No. records had semicolon corrected: "_$JUSTIFY(RAC1,7)
DO STOR
+5 SET RA3="No. records updated in file 101.43: "_$JUSTIFY(RAC2,7)
DO STOR
+6 SET RA3="No. records locked and not updated: "_$JUSTIFY(RABADTOT,7)
DO STOR
+7 DO MAIL
+8 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+9 QUIT
STOR ; store messages and totals
+1 if $GET(RA3)=""
QUIT
+2 SET RAC=RAC+1
SET ^TMP($JOB,"RA34PST",RAC)=RA3
+3 QUIT
REMOV ; remove ";"
+1 SET RAC1=RAC1+1
+2 SET RAFDA(71,RAI_",",.01)=RA2
+3 DO FILE^DIE("E","RAFDA")
+4 KILL RAFDA
+5 QUIT
CPRS ; update record in Orderable Items file 101.43
+1 ;skip update if no Order Dialog file 101.41
if $$ORQUIK^RAORDU()'=1
QUIT
+2 ; skip if inactive
+3 IF $SELECT('$DATA(^RAMIS(71,RAI,"I")):0,^("I")="":0,+^("I")>DT:0,1:1)
QUIT
+4 SET RAC2=RAC2+1
+5 SET RASTAT="1^1"
+6 SET RAY=RAI_"^"_RA2
+7 DO PROC^RAO7MFN(0,71,RASTAT,RAY)
+8 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="^TMP($J,""RA34PST"","
+3 SET XMSUB="Results from routine RA34PST"
+4 SET XMY(DUZ)=""
DO ^XMD
+5 QUIT
