Changeset 623 for WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXCF.m

Timestamp:

Dec 4, 2009, 12:11:15 AM (14 years ago)

Author:

George Lilly

Message:

revised back to 6/30/08 version

File:

• WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXCF.m (modified) (1 diff)

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXCF.m

@@ -1 @@
-PXRMEXCF        ; SLC/PKR - Reminder exchange routines for computed findings. ;06/28/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;==============================================
-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."
-        .. 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
-        ;
+PXRMEXCF ; SLC/PKR - Reminder exchange routines for computed findings. ;12/22/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;==============================================
+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,DIR,DIROUT,DIRUT,DTOUT,DUOUT,ECS,IND,MSG
+ N PCS,ROUTINE,SAME,TEXT,X,Y
+ S NEWNAME=""
+ ;If the routine exists compare the existing routine checksum with the
+ ;the checksum of the routine in the packed definition.
+ S ROUTINE=ATTR("NAME")
+ I EXISTS="" S EXISTS=$$EXISTS^PXRMEXCF(ROUTINE)
+ S CHOICES=$S(EXISTS:"COQS",1:"CIQS")
+ I EXISTS D
+ . S SAME=$$SAME(.ATTR,.RTN)
+ . S TEXT(1)="Routine "_ROUTINE_" already exists "
+ . I SAME S TEXT(1)=TEXT(1)_"and the packed routine is identical,"
+ . I 'SAME S TEXT(1)=TEXT(1)_"but the packed routine is different,"
+ . S TEXT(2)="what do you want to do?"
+ . D EN^DDIOL(.TEXT)
+ . 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" 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
+ ;
+ ;==============================================
+SAME(ATTR,RTN) ;Compare the existing routine and the new version
+ ;in RTN to see if they are the same.
+ N ECS,DIF,NEWCS,RT,SAME,X,XCNP
+ ;Load the existing routine into RT.
+ S XCNP=0
+ S DIF="RT("
+ S X=ATTR("NAME")
+ X ^%ZOSF("LOAD")
+ S ECS=$$ROUTINE^PXRMEXCS(.RT)
+ K RT
+ S NEWCS=$$ROUTINE^PXRMEXCS(.RTN)
+ S SAME=$S(ECS=NEWCS:1,1:0)
+ Q SAME
+ ;