- 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 ;
