Routine: RA34PST

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)

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)")

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="@"

STOR ; store messages and totals

 Q:$G(RA3)=""

 S RAC=RAC+1,^TMP($J,"RA34PST",RAC)=RA3

REMOV ; remove ";"

 S RAC1=RAC1+1

 S RAFDA(71,RAI_",",.01)=RA2

 D FILE^DIE("E","RAFDA")

 K RAFDA

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)

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRA34PST   3675     printed  Feb 18, 2025@23:59:32                                                                                                                                                                                                     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

RA34PST.m