PXRMEXCF ; SLC/PKR - Reminder exchange routines for computed findings. ;10/17/2008
;;2.0;CLINICAL REMINDERS;**6,12**;Feb 04, 2005;Build 73
;==============================================
EXISTS(ROUTINE) ;Return true if routine ROUTINE exists.
I ROUTINE="" Q 0
N RTN
S RTN="^"_ROUTINE
Q $S($T(@RTN)'="":1,1:0)
;
;==============================================
GETRACT(ATTR,NEWNAME,NAMECHG,RTN,EXISTS) ;Get the action for a routine.
N ACTION,CHOICES,CSUM,DIR,DIROUT,DIRUT,DTOUT,DUOUT,ECS,IND,MSG
N PCS,ROUTINE,SAME,TEXT,X,Y
S NEWNAME=""
S ROUTINE=ATTR("NAME")
I EXISTS="" S EXISTS=$$EXISTS^PXRMEXCF(ROUTINE)
S CHOICES=$S(EXISTS:"COQS",1:"CIQS")
I EXISTS D
.;If the routine exists compare the existing routine checksum with the
.;the checksum of the routine in the packed definition.
. S CSUM=$$RTNCS^PXRMEXCS(ROUTINE)
. S SAME=$S(ATTR("CHECKSUM")=CSUM:1,1:0)
. S TEXT(1)="Routine "_ROUTINE_" already exists "
. I SAME D
.. S TEXT(1)=TEXT(1)_"and the packed routine is identical, skipping."
.. I $D(PXRMDEBG) W !,TEXT(1),! H 2
.. S ACTION="S"
. I 'SAME D
.. S TEXT(1)=TEXT(1)_"but the packed routine is different,"
.. S TEXT(2)="what do you want to do?"
.. W !,TEXT(1),!,TEXT(2)
.. S DIR("B")="O"
.. S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
E D
. W !!,"Routine "_ROUTINE_" is new, what do you want to do?"
. S DIR("B")="I"
. S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
;
I (ACTION="Q")!(ACTION="S") Q ACTION
;
I ACTION="C" D
. N CDONE
. S CDONE=0
. F Q:CDONE D
.. S NEWNAME=$$GETNAME^PXRMEXIU(ATTR("MIN FIELD LENGTH"),ATTR("FIELD LENGTH"))
.. I NEWNAME="" S ACTION="S",CDONE=1 Q
.. S EXISTS=$$EXISTS^PXRMEXCF(NEWNAME)
.. I EXISTS W !,"Routine ",NEWNAME," already exists, try again."
.. E D Q
... S CDONE=1
... S NAMECHG(ATTR("FILE NUMBER"),ROUTINE)=NEWNAME
;
I (ACTION="I")&(EXISTS) D
.;If the action is overwrite double check that overwrite is what the
.;user really wants to do.
. K DIR
. S DIR(0)="Y"_U_"A"
. S DIR("A")="Are you sure you want to overwrite"
. S DIR("B")="N"
. D ^DIR
. I $D(DIROUT)!$D(DIRUT) S Y=0
. I $D(DTOUT)!$D(DUOUT) S Y=0
. I 'Y S ACTION="S"
. S NAMECHG(ATTR("FILE NUMBER"),ROUTINE)=NEWNAME
Q ACTION
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMEXCF 2255 printed Dec 13, 2024@01:44:50 Page 2
PXRMEXCF ; SLC/PKR - Reminder exchange routines for computed findings. ;10/17/2008
+1 ;;2.0;CLINICAL REMINDERS;**6,12**;Feb 04, 2005;Build 73
+2 ;==============================================
EXISTS(ROUTINE) ;Return true if routine ROUTINE exists.
+1 IF ROUTINE=""
QUIT 0
+2 NEW RTN
+3 SET RTN="^"_ROUTINE
+4 QUIT $SELECT($TEXT(@RTN)'="":1,1:0)
+5 ;
+6 ;==============================================
GETRACT(ATTR,NEWNAME,NAMECHG,RTN,EXISTS) ;Get the action for a routine.
+1 NEW ACTION,CHOICES,CSUM,DIR,DIROUT,DIRUT,DTOUT,DUOUT,ECS,IND,MSG
+2 NEW PCS,ROUTINE,SAME,TEXT,X,Y
+3 SET NEWNAME=""
+4 SET ROUTINE=ATTR("NAME")
+5 IF EXISTS=""
SET EXISTS=$$EXISTS^PXRMEXCF(ROUTINE)
+6 SET CHOICES=$SELECT(EXISTS:"COQS",1:"CIQS")
+7 IF EXISTS
Begin DoDot:1
+8 ;If the routine exists compare the existing routine checksum with the
+9 ;the checksum of the routine in the packed definition.
+10 SET CSUM=$$RTNCS^PXRMEXCS(ROUTINE)
+11 SET SAME=$SELECT(ATTR("CHECKSUM")=CSUM:1,1:0)
+12 SET TEXT(1)="Routine "_ROUTINE_" already exists "
+13 IF SAME
Begin DoDot:2
+14 SET TEXT(1)=TEXT(1)_"and the packed routine is identical, skipping."
+15 IF $DATA(PXRMDEBG)
WRITE !,TEXT(1),!
HANG 2
+16 SET ACTION="S"
End DoDot:2
+17 IF 'SAME
Begin DoDot:2
+18 SET TEXT(1)=TEXT(1)_"but the packed routine is different,"
+19 SET TEXT(2)="what do you want to do?"
+20 WRITE !,TEXT(1),!,TEXT(2)
+21 SET DIR("B")="O"
+22 SET ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
End DoDot:2
End DoDot:1
+23 IF '$TEST
Begin DoDot:1
+24 WRITE !!,"Routine "_ROUTINE_" is new, what do you want to do?"
+25 SET DIR("B")="I"
+26 SET ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
End DoDot:1
+27 ;
+28 IF (ACTION="Q")!(ACTION="S")
QUIT ACTION
+29 ;
+30 IF ACTION="C"
Begin DoDot:1
+31 NEW CDONE
+32 SET CDONE=0
+33 FOR
if CDONE
QUIT
Begin DoDot:2
+34 SET NEWNAME=$$GETNAME^PXRMEXIU(ATTR("MIN FIELD LENGTH"),ATTR("FIELD LENGTH"))
+35 IF NEWNAME=""
SET ACTION="S"
SET CDONE=1
QUIT
+36 SET EXISTS=$$EXISTS^PXRMEXCF(NEWNAME)
+37 IF EXISTS
WRITE !,"Routine ",NEWNAME," already exists, try again."
+38 IF '$TEST
Begin DoDot:3
+39 SET CDONE=1
+40 SET NAMECHG(ATTR("FILE NUMBER"),ROUTINE)=NEWNAME
End DoDot:3
QUIT
End DoDot:2
End DoDot:1
+41 ;
+42 IF (ACTION="I")&(EXISTS)
Begin DoDot:1
+43 ;If the action is overwrite double check that overwrite is what the
+44 ;user really wants to do.
+45 KILL DIR
+46 SET DIR(0)="Y"_U_"A"
+47 SET DIR("A")="Are you sure you want to overwrite"
+48 SET DIR("B")="N"
+49 DO ^DIR
+50 IF $DATA(DIROUT)!$DATA(DIRUT)
SET Y=0
+51 IF $DATA(DTOUT)!$DATA(DUOUT)
SET Y=0
+52 IF 'Y
SET ACTION="S"
+53 SET NAMECHG(ATTR("FILE NUMBER"),ROUTINE)=NEWNAME
End DoDot:1
+54 QUIT ACTION
+55 ;
