| 1 | PXRMEXCF ; SLC/PKR - Reminder exchange routines for computed findings. ;12/22/2004
|
|---|
| 2 | ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
|
|---|
| 3 | ;==============================================
|
|---|
| 4 | EXISTS(ROUTINE) ;Return true if routine ROUTINE exists.
|
|---|
| 5 | I ROUTINE="" Q 0
|
|---|
| 6 | N RTN
|
|---|
| 7 | S RTN="^"_ROUTINE
|
|---|
| 8 | Q $S($T(@RTN)'="":1,1:0)
|
|---|
| 9 | ;
|
|---|
| 10 | ;==============================================
|
|---|
| 11 | GETRACT(ATTR,NEWNAME,NAMECHG,RTN,EXISTS) ;Get the action for a routine.
|
|---|
| 12 | N ACTION,CHOICES,DIR,DIROUT,DIRUT,DTOUT,DUOUT,ECS,IND,MSG
|
|---|
| 13 | N PCS,ROUTINE,SAME,TEXT,X,Y
|
|---|
| 14 | S NEWNAME=""
|
|---|
| 15 | ;If the routine exists compare the existing routine checksum with the
|
|---|
| 16 | ;the checksum of the routine in the packed definition.
|
|---|
| 17 | S ROUTINE=ATTR("NAME")
|
|---|
| 18 | I EXISTS="" S EXISTS=$$EXISTS^PXRMEXCF(ROUTINE)
|
|---|
| 19 | S CHOICES=$S(EXISTS:"COQS",1:"CIQS")
|
|---|
| 20 | I EXISTS D
|
|---|
| 21 | . S SAME=$$SAME(.ATTR,.RTN)
|
|---|
| 22 | . S TEXT(1)="Routine "_ROUTINE_" already exists "
|
|---|
| 23 | . I SAME S TEXT(1)=TEXT(1)_"and the packed routine is identical,"
|
|---|
| 24 | . I 'SAME S TEXT(1)=TEXT(1)_"but the packed routine is different,"
|
|---|
| 25 | . S TEXT(2)="what do you want to do?"
|
|---|
| 26 | . D EN^DDIOL(.TEXT)
|
|---|
| 27 | . S DIR("B")="S"
|
|---|
| 28 | . S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
|
|---|
| 29 | E D
|
|---|
| 30 | . W !!,"Routine "_ROUTINE_" is NEW, what do you want to do?"
|
|---|
| 31 | . S DIR("B")="I"
|
|---|
| 32 | . S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
|
|---|
| 33 | ;
|
|---|
| 34 | I ACTION="Q" Q ACTION
|
|---|
| 35 | ;
|
|---|
| 36 | I ACTION="C" D
|
|---|
| 37 | . N CDONE
|
|---|
| 38 | . S CDONE=0
|
|---|
| 39 | . F Q:CDONE D
|
|---|
| 40 | .. S NEWNAME=$$GETNAME^PXRMEXIU(ATTR("MIN FIELD LENGTH"),ATTR("FIELD LENGTH"))
|
|---|
| 41 | .. I NEWNAME="" S ACTION="S",CDONE=1 Q
|
|---|
| 42 | .. S EXISTS=$$EXISTS^PXRMEXCF(NEWNAME)
|
|---|
| 43 | .. I EXISTS W !,"Routine ",NEWNAME," already exists, try again."
|
|---|
| 44 | .. E D Q
|
|---|
| 45 | ... S CDONE=1
|
|---|
| 46 | ... S NAMECHG(ATTR("FILE NUMBER"),ROUTINE)=NEWNAME
|
|---|
| 47 | ;
|
|---|
| 48 | I (ACTION="I")&(EXISTS) D
|
|---|
| 49 | .;If the action is overwrite double check that overwrite is what the
|
|---|
| 50 | .;user really wants to do.
|
|---|
| 51 | . K DIR
|
|---|
| 52 | . S DIR(0)="Y"_U_"A"
|
|---|
| 53 | . S DIR("A")="Are you sure you want to overwrite"
|
|---|
| 54 | . S DIR("B")="N"
|
|---|
| 55 | . D ^DIR
|
|---|
| 56 | . I $D(DIROUT)!$D(DIRUT) S Y=0
|
|---|
| 57 | . I $D(DTOUT)!$D(DUOUT) S Y=0
|
|---|
| 58 | . I 'Y S ACTION="S"
|
|---|
| 59 | . S NAMECHG(ATTR("FILE NUMBER"),ROUTINE)=NEWNAME
|
|---|
| 60 | Q ACTION
|
|---|
| 61 | ;
|
|---|
| 62 | ;==============================================
|
|---|
| 63 | SAME(ATTR,RTN) ;Compare the existing routine and the new version
|
|---|
| 64 | ;in RTN to see if they are the same.
|
|---|
| 65 | N ECS,DIF,NEWCS,RT,SAME,X,XCNP
|
|---|
| 66 | ;Load the existing routine into RT.
|
|---|
| 67 | S XCNP=0
|
|---|
| 68 | S DIF="RT("
|
|---|
| 69 | S X=ATTR("NAME")
|
|---|
| 70 | X ^%ZOSF("LOAD")
|
|---|
| 71 | S ECS=$$ROUTINE^PXRMEXCS(.RT)
|
|---|
| 72 | K RT
|
|---|
| 73 | S NEWCS=$$ROUTINE^PXRMEXCS(.RTN)
|
|---|
| 74 | S SAME=$S(ECS=NEWCS:1,1:0)
|
|---|
| 75 | Q SAME
|
|---|
| 76 | ;
|
|---|
