PXRMEXCF ; SLC/PKR - Reminder exchange routines for computed findings. ;23-Mar-2015 10:12;DU
;;2.0;CLINICAL REMINDERS;**6,1001,12,1005**;Feb 04, 2005;Build 23
;IHS/MSC/MGH change to skip on routines
;==============================================
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"
. ;IHS/MSC/MGH since routines are sent in patches, skip
. I 'SAME D
.. S TEXT(1)=TEXT(1)_"but the packed routine is different,"
.. ;S TEXT(2)="what do you want to do?"
.. S TEXT(2)="Normally,SKIP is the appropriate answer"
.. W !,TEXT(1),!,TEXT(2)
.. S DIR("B")="S"
.. 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
;
PXRMEXCF ; SLC/PKR - Reminder exchange routines for computed findings. ;23-Mar-2015 10:12;DU
+1 ;;2.0;CLINICAL REMINDERS;**6,1001,12,1005**;Feb 04, 2005;Build 23
+2 ;IHS/MSC/MGH change to skip on routines
+3 ;==============================================
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 ;IHS/MSC/MGH since routines are sent in patches, skip
+18 IF 'SAME
Begin DoDot:2
+19 SET TEXT(1)=TEXT(1)_"but the packed routine is different,"
+20 ;S TEXT(2)="what do you want to do?"
+21 SET TEXT(2)="Normally,SKIP is the appropriate answer"
+22 WRITE !,TEXT(1),!,TEXT(2)
+23 SET DIR("B")="S"
+24 SET ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
End DoDot:2
End DoDot:1
+25 IF '$TEST
Begin DoDot:1
+26 WRITE !!,"Routine "_ROUTINE_" is new, what do you want to do?"
+27 SET DIR("B")="I"
+28 SET ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
End DoDot:1
+29 ;
+30 IF (ACTION="Q")!(ACTION="S")
QUIT ACTION
+31 ;
+32 IF ACTION="C"
Begin DoDot:1
+33 NEW CDONE
+34 SET CDONE=0
+35 FOR
IF CDONE
QUIT
Begin DoDot:2
+36 SET NEWNAME=$$GETNAME^PXRMEXIU(ATTR("MIN FIELD LENGTH"),ATTR("FIELD LENGTH"))
+37 IF NEWNAME=""
SET ACTION="S"
SET CDONE=1
QUIT
+38 SET EXISTS=$$EXISTS^PXRMEXCF(NEWNAME)
+39 IF EXISTS
WRITE !,"Routine ",NEWNAME," already exists, try again."
+40 IF '$TEST
Begin DoDot:3
+41 SET CDONE=1
+42 SET NAMECHG(ATTR("FILE NUMBER"),ROUTINE)=NEWNAME
End DoDot:3
QUIT
End DoDot:2
End DoDot:1
+43 ;
+44 IF (ACTION="I")&(EXISTS)
Begin DoDot:1
+45 ;If the action is overwrite double check that overwrite is what the
+46 ;user really wants to do.
+47 KILL DIR
+48 SET DIR(0)="Y"_U_"A"
+49 SET DIR("A")="Are you sure you want to overwrite"
+50 SET DIR("B")="N"
+51 DO ^DIR
+52 IF $DATA(DIROUT)!$DATA(DIRUT)
SET Y=0
+53 IF $DATA(DTOUT)!$DATA(DUOUT)
SET Y=0
+54 IF 'Y
SET ACTION="S"
+55 SET NAMECHG(ATTR("FILE NUMBER"),ROUTINE)=NEWNAME
End DoDot:1
+56 QUIT ACTION
+57 ;
