PXRMTMED.m

PXRMTMED ; SLC/PKR/PJH - Edit a reminder term. ;05/27/2014

 ;;2.0;CLINICAL REMINDERS;**1,4,6,12,26**;Feb 04, 2005;Build 404

 ;

 ;=======================================================

 N CS1,CS2,DA,DIC,DLAYGO,DTOUT,DUOUT,Y

GETNAME ;Get the name of the term to edit.

 K DA,DIC,DLAYGO,DTOUT,DUOUT,Y

 S DIC="^PXRMD(811.5,"

 S DIC(0)="AEMQL"

 S DIC("A")="Select Reminder Term: "

 S DLAYGO=811.5

 ;Set the starting place for additions.

 D SETSTART^PXRMCOPY(DIC)

 W !

 D ^DIC

 I ($D(DTOUT))!($D(DUOUT)) Q

 I Y=-1 G END

 S DA=$P(Y,U,1)

 S CS1=$$FILE^PXRMEXCS(811.5,DA)

 D EDIT(DIC,DA)

 I $G(DA)="" G GETNAME

 S CS2=$$FILE^PXRMEXCS(811.5,DA)

 I CS2=0 G GETNAME

 I CS2'=CS1 D SEHIST^PXRMUTIL(811.5,DIC,DA)

 G GETNAME

END ;

 Q

 ;

 ;=======================================================

CLASS(DA,DIE) ;

 N DR,RESULT,X,Y

RETRY W !

 S DR="100" D ^DIE I $D(Y) Q

 ;Sponsor

 S DR="101" D ^DIE I $D(Y) Q

 ;Make sure Class and Sponsor Class are in synch.

 S RESULT=$$VSPONSOR^PXRMINTR(X)

 I RESULT=0 S DIE("NO^")="Other value" G RETRY

 I RESULT=1 K DIE("NO^")

 ;Review date, Usage

 S DR="102;1" D ^DIE I $D(Y) Q

 Q

 ;

 ;=======================================================

EDIT(ROOT,DA) ;

 N CLASS,DIC,DIE,DR,DIDEL,PXRMTMD,RESULT,TCONT,Y

 ;PXRMTMD is set by a xref on the .01 as a flag that the entire

 ;entry is being deleted.

 S CLASS=$P($G(^PXRMD(811.5,DA,100)),U,1)

 S DIE=ROOT

 I CLASS'="N"!(($G(PXRMINST)=1)&($G(DUZ(0))="@")) D

 . S DR=".01"

 . D ^DIE

 . I $G(DA)'="" D CLASS(DA,DIE)

 I $G(DA)="" Q

 S TCONT=1

 F  D FINDING(ROOT,DA)  Q:TCONT=0

 Q

 ;

 ;=======================================================

FINDING(DIE,DA) ;

 N CFIEN,GLOB,IEN,LIST,NODE,TERMSTAT,VF,WPIEN

 N DEF,DEF1,DEF2,STATUS

 S DIE("NO^")="OUTOK"

 S STATUS=0

 D DEF^PXRMRUTL("811.52",.DEF,.DEF1,.DEF2)

 S NODE="^PXRMD(811.5)"

 D LIST^PXRMREDT(NODE,DA,.DEF1,.LIST)

 D DSPALL^PXRMREDF("T",NODE,DA,.LIST)

 S DA(1)=DA

 S IEN=DA

 S DIC=DIE_DA(1)_",20,"

 S DIC(0)="QEAL"

 S DIC("A")="Select Finding: "

 D ^DIC I Y=-1 S DTOUT=1,TCONT=0 Q

 S DIE=DIC

 S DA=+Y,GLOB=$P($P(Y,U,2),";",2) Q:GLOB=""

 I GLOB="PXRMD(811.4," S CFIEN=$P($P(Y,U,2),";",1) D

 . I $D(^PXRMD(811.4,CFIEN,1))>0 D

 .. W !!,"Computed Finding Description:" S WPIEN=0

 .. F  S WPIEN=$O(^PXRMD(811.4,CFIEN,1,WPIEN)) Q:+WPIEN'>0  D

 ... W !,$G(^PXRMD(811.4,CFIEN,1,WPIEN,0))

 . E  W !!,"No description defined for this computed finding"

 . W !

 I GLOB="YTT(601.71," D WARN^PXRMMH

 W !,"Editing Finding Number: "_$G(DA)

 ;Finding record fields

 S DR=".01;9;12;17"

 I GLOB="PXRMD(811.4," S DR=DR_";26"

 ;Taxonomy - use inactive problems

 I GLOB="PXD(811.2," D

 .S TERMSTAT=$$TAXNODE^PXRMSTA1($P($P(Y,U,2),";"))

 .I TERMSTAT="P" S DR=DR_";10" Q

 .I TERMSTAT'=0 S DR=DR_";10",STATUS=1

 ;Health Factor - within category rank

 I GLOB="AUTTHF(" S DR=DR_";11"

 ;If V file INCLUDE VISIT DATA

 S VF=$S(GLOB["AUTTEDT":1,GLOB["AUTTEXAM":1,GLOB["AUTTHF":1,GLOB["AUTTIMM":1,GLOB="AUTTSK":1,GLOB["PXD(811.2":1,1:0)

 I VF S DR=DR_";28"

 ;Mental Health - scale

 I GLOB="YTT(601.71," S DR=DR_";13"

 ;Radiology procedure

 I GLOB="RAMIS(71," S STATUS=1

 ;Orderable item

 I GLOB="ORD(101.43," S DR=DR_";27",STATUS=1

 ;Rx Type

 I GLOB="PSDRUG("!(GLOB="PS(50.605,")!(GLOB="PSNDF(50.6,") S DR=DR_";16;27",STATUS=1

 ;Condition

 S DR=DR_";14;15;18"

 ;

 ;Edit finding record

 D ^DIE

 I STATUS=1,$D(DA)>0,$D(Y)=0 D STATUS^PXRMSTA1(.DA,"T")

 S $P(^PXRMD(811.5,IEN,20,0),U,3)=0

 Q

 ;

PXRMTMED  ; SLC/PKR/PJH - Edit a reminder term. ;05/27/2014

 +1       ;;2.0;CLINICAL REMINDERS;**1,4,6,12,26**;Feb 04, 2005;Build 404

 +2       ;

 +3       ;=======================================================

 +4        NEW CS1,CS2,DA,DIC,DLAYGO,DTOUT,DUOUT,Y

GETNAME   ;Get the name of the term to edit.

 +1        KILL DA,DIC,DLAYGO,DTOUT,DUOUT,Y

 +2        SET DIC="^PXRMD(811.5,"

 +3        SET DIC(0)="AEMQL"

 +4        SET DIC("A")="Select Reminder Term: "

 +5        SET DLAYGO=811.5

 +6       ;Set the starting place for additions.

 +7        DO SETSTART^PXRMCOPY(DIC)

 +8        WRITE !

 +9        DO ^DIC

 +10       IF ($DATA(DTOUT))!($DATA(DUOUT))

               QUIT 

 +11       IF Y=-1

               GOTO END

 +12       SET DA=$PIECE(Y,U,1)

 +13       SET CS1=$$FILE^PXRMEXCS(811.5,DA)

 +14       DO EDIT(DIC,DA)

 +15       IF $GET(DA)=""

               GOTO GETNAME

 +16       SET CS2=$$FILE^PXRMEXCS(811.5,DA)

 +17       IF CS2=0

               GOTO GETNAME

 +18       IF CS2'=CS1

               DO SEHIST^PXRMUTIL(811.5,DIC,DA)

 +19       GOTO GETNAME

END       ;

 +1        QUIT 

 +2       ;

 +3       ;=======================================================

CLASS(DA,DIE) ;

 +1        NEW DR,RESULT,X,Y

RETRY      WRITE !

 +1        SET DR="100"

           DO ^DIE

           IF $DATA(Y)

               QUIT 

 +2       ;Sponsor

 +3        SET DR="101"

           DO ^DIE

           IF $DATA(Y)

               QUIT 

 +4       ;Make sure Class and Sponsor Class are in synch.

 +5        SET RESULT=$$VSPONSOR^PXRMINTR(X)

 +6        IF RESULT=0

               SET DIE("NO^")="Other value"

               GOTO RETRY

 +7        IF RESULT=1

               KILL DIE("NO^")

 +8       ;Review date, Usage

 +9        SET DR="102;1"

           DO ^DIE

           IF $DATA(Y)

               QUIT 

 +10       QUIT 

 +11      ;

 +12      ;=======================================================

EDIT(ROOT,DA) ;

 +1        NEW CLASS,DIC,DIE,DR,DIDEL,PXRMTMD,RESULT,TCONT,Y

 +2       ;PXRMTMD is set by a xref on the .01 as a flag that the entire

 +3       ;entry is being deleted.

 +4        SET CLASS=$PIECE($GET(^PXRMD(811.5,DA,100)),U,1)

 +5        SET DIE=ROOT

 +6        IF CLASS'="N"!(($GET(PXRMINST)=1)&($GET(DUZ(0))="@"))

               Begin DoDot:1

 +7                SET DR=".01"

 +8                DO ^DIE

 +9                IF $GET(DA)'=""

                       DO CLASS(DA,DIE)

               End DoDot:1

 +10       IF $GET(DA)=""

               QUIT 

 +11       SET TCONT=1

 +12       FOR 

               DO FINDING(ROOT,DA)

               IF TCONT=0

                   QUIT 

 +13       QUIT 

 +14      ;

 +15      ;=======================================================

FINDING(DIE,DA) ;

 +1        NEW CFIEN,GLOB,IEN,LIST,NODE,TERMSTAT,VF,WPIEN

 +2        NEW DEF,DEF1,DEF2,STATUS

 +3        SET DIE("NO^")="OUTOK"

 +4        SET STATUS=0

 +5        DO DEF^PXRMRUTL("811.52",.DEF,.DEF1,.DEF2)

 +6        SET NODE="^PXRMD(811.5)"

 +7        DO LIST^PXRMREDT(NODE,DA,.DEF1,.LIST)

 +8        DO DSPALL^PXRMREDF("T",NODE,DA,.LIST)

 +9        SET DA(1)=DA

 +10       SET IEN=DA

 +11       SET DIC=DIE_DA(1)_",20,"

 +12       SET DIC(0)="QEAL"

 +13       SET DIC("A")="Select Finding: "

 +14       DO ^DIC

           IF Y=-1

               SET DTOUT=1

               SET TCONT=0

               QUIT 

 +15       SET DIE=DIC

 +16       SET DA=+Y

           SET GLOB=$PIECE($PIECE(Y,U,2),";",2)

           IF GLOB=""

               QUIT 

 +17       IF GLOB="PXRMD(811.4,"

               SET CFIEN=$PIECE($PIECE(Y,U,2),";",1)

               Begin DoDot:1

 +18               IF $DATA(^PXRMD(811.4,CFIEN,1))>0

                       Begin DoDot:2

 +19                       WRITE !!,"Computed Finding Description:"

                           SET WPIEN=0

 +20                       FOR 

                               SET WPIEN=$ORDER(^PXRMD(811.4,CFIEN,1,WPIEN))

                               IF +WPIEN'>0

                                   QUIT 

                               Begin DoDot:3

 +21                               WRITE !,$GET(^PXRMD(811.4,CFIEN,1,WPIEN,0))

                               End DoDot:3

                       End DoDot:2

 +22              IF '$TEST

                       WRITE !!,"No description defined for this computed finding"

 +23               WRITE !

               End DoDot:1

 +24       IF GLOB="YTT(601.71,"

               DO WARN^PXRMMH

 +25       WRITE !,"Editing Finding Number: "_$GET(DA)

 +26      ;Finding record fields

 +27       SET DR=".01;9;12;17"

 +28       IF GLOB="PXRMD(811.4,"

               SET DR=DR_";26"

 +29      ;Taxonomy - use inactive problems

 +30       IF GLOB="PXD(811.2,"

               Begin DoDot:1

 +31               SET TERMSTAT=$$TAXNODE^PXRMSTA1($PIECE($PIECE(Y,U,2),";"))

 +32               IF TERMSTAT="P"

                       SET DR=DR_";10"

                       QUIT 

 +33               IF TERMSTAT'=0

                       SET DR=DR_";10"

                       SET STATUS=1

               End DoDot:1

 +34      ;Health Factor - within category rank

 +35       IF GLOB="AUTTHF("

               SET DR=DR_";11"

 +36      ;If V file INCLUDE VISIT DATA

 +37       SET VF=$SELECT(GLOB["AUTTEDT":1,GLOB["AUTTEXAM":1,GLOB["AUTTHF":1,GLOB["AUTTIMM":1,GLOB="AUTTSK":1,GLOB["PXD(811.2":1,1:0)

 +38       IF VF

               SET DR=DR_";28"

 +39      ;Mental Health - scale

 +40       IF GLOB="YTT(601.71,"

               SET DR=DR_";13"

 +41      ;Radiology procedure

 +42       IF GLOB="RAMIS(71,"

               SET STATUS=1

 +43      ;Orderable item

 +44       IF GLOB="ORD(101.43,"

               SET DR=DR_";27"

               SET STATUS=1

 +45      ;Rx Type

 +46       IF GLOB="PSDRUG("!(GLOB="PS(50.605,")!(GLOB="PSNDF(50.6,")

               SET DR=DR_";16;27"

               SET STATUS=1

 +47      ;Condition

 +48       SET DR=DR_";14;15;18"

 +49      ;

 +50      ;Edit finding record

 +51       DO ^DIE

 +52       IF STATUS=1

               IF $DATA(DA)>0

                   IF $DATA(Y)=0

                       DO STATUS^PXRMSTA1(.DA,"T")

 +53       SET $PIECE(^PXRMD(811.5,IEN,20,0),U,3)=0

 +54       QUIT 

 +55      ;