PXRMDD41.m

PXRMDD41 ;SLC/PJH - Reminder Dialog file calls ;10/19/2015  09:13

 ;;2.0;CLINICAL REMINDERS;**45**;Feb 04, 2005;Build 566

 ;

 ;copied from ORDD41 for dialog reminders

KILL(DLG) ;

 Q

 ;

 ; Update audit trail when ITEMS changed

REDOX I $D(^PXRMD(801.41,+$G(DA(1)),0)) S $P(^(99),U)=$$NOW^XLFDT

 Q

 ;

SCREEN ;validate dialog type

 Q:'$G(DA(1))

 N PXRMMTYP

 S PXRMMTYP=$P($G(^PXRMD(801.41,DA(1),0)),U,4)

 ;MH results and Reminder dialogs dissallowed

 S DIC("S")="I ""RST""'[$P(^(0),U,4)"

 ;Dialog elements can only contain prompts/forced values

 I PXRMMTYP="E" S DIC("S")="I ""FP""[$P(^(0),U,4)"

 ;Reminder dialogs can contain only Elements and Groups

 I PXRMMTYP="R" S DIC("S")="I ""EG""[$P(^(0),U,4)"

 ;MH Result Groups can only contain MH Result Elementss

 I PXRMMTYP="S" S DIC("S")="I ""T""=$P(^(0),U,4)"

 ;Dialog groups cannot point to themselves

 I PXRMMTYP="G" D

 .;S DIC("S")=DIC("S")_",$G(Y)'=DA(1)"

 .S DIC("S")=DIC("S")_",$G(Y)'=DA(1),$$VGROUP^PXRMDD41($G(Y),DA(1))=0"

 Q

 ;

 ; UPDATE last amend date

SET(DLG) ;

 S $P(^PXRMD(801.41,DLG,99),U)=$$NOW^XLFDT

 Q

 ;

 ; -- Ck menu tree to ensure new item is not an ancestor

 ;    Input Xform for Item field #2 of Items subfile #801.412

 ;      expecting DA, DA(1), X from FileMan

TREE ;

 D SCREEN

 N PXRMDDA,PXRMDD S PXRMDDA=DA(1)

 K:X=PXRMDDA X D TREE1

 Q

 ; -- Look for X in ancestors

TREE1 F PXRMDD=0:0 Q:'$D(X)  S PXRMDD=$O(^PXRMD(801.41,"AD",PXRMDDA,PXRMDD)) Q:PXRMDD'>0  K:X=PXRMDD X Q:'$D(X)  D TREE2

 Q

 ; Back up another level

TREE2 N PXRMDDA S PXRMDDA=PXRMDD N PXRMDD D TREE1

 Q

 ;

VGROUP(DIEN,IEN) ;Check dialog index to see if group will point to itself 

 N FOUND

 S FOUND=0

 ;

 ;Only do check if dialog is a group

 I $P($G(^PXRMD(801.41,DIEN,0)),U,4)'="G" Q FOUND

 ;

 ;Group cannot be added to itself

 I DIEN=IEN S FOUND=1 Q FOUND

 ;

 ;IEN is the dialog group being added to 

 D VGROUP1(DIEN,IEN)

 Q FOUND

 ;

VGROUP1(DIEN,IEN) ;Examine all parent dialogs

 ;

 ;End search if already found

 Q:FOUND

 ;

 ;Check if dialog being added is a parent at this level

 I $D(^PXRMD(801.41,"AD",IEN,DIEN)) S FOUND=1 Q

 ;

 ;If not look at other parents

 N SUB,TIEN

 S SUB=0

 F  S SUB=$O(^PXRMD(801.41,"AD",IEN,SUB)) Q:'SUB  D  Q:FOUND

 .;Ignore reminder dialogs

 .I $P($G(^PXRMD(801.41,SUB,0)),U,4)'="G" Q

 .;Repeat check on other parents

 .D VGROUP1(DIEN,SUB)

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PXRMDD41   2393     printed  Feb 18, 2025@23:09:59                                                                                                                                                                                                    Page 2

PXRMDD41  ;SLC/PJH - Reminder Dialog file calls ;10/19/2015  09:13

 +1       ;;2.0;CLINICAL REMINDERS;**45**;Feb 04, 2005;Build 566

 +2       ;

 +3       ;copied from ORDD41 for dialog reminders

KILL(DLG) ;

 +1        QUIT 

 +2       ;

 +3       ; Update audit trail when ITEMS changed

REDOX      IF $DATA(^PXRMD(801.41,+$GET(DA(1)),0))

               SET $PIECE(^(99),U)=$$NOW^XLFDT

 +1        QUIT 

 +2       ;

SCREEN    ;validate dialog type

 +1        if '$GET(DA(1))

               QUIT 

 +2        NEW PXRMMTYP

 +3        SET PXRMMTYP=$PIECE($GET(^PXRMD(801.41,DA(1),0)),U,4)

 +4       ;MH results and Reminder dialogs dissallowed

 +5        SET DIC("S")="I ""RST""'[$P(^(0),U,4)"

 +6       ;Dialog elements can only contain prompts/forced values

 +7        IF PXRMMTYP="E"

               SET DIC("S")="I ""FP""[$P(^(0),U,4)"

 +8       ;Reminder dialogs can contain only Elements and Groups

 +9        IF PXRMMTYP="R"

               SET DIC("S")="I ""EG""[$P(^(0),U,4)"

 +10      ;MH Result Groups can only contain MH Result Elementss

 +11       IF PXRMMTYP="S"

               SET DIC("S")="I ""T""=$P(^(0),U,4)"

 +12      ;Dialog groups cannot point to themselves

 +13       IF PXRMMTYP="G"

               Begin DoDot:1

 +14      ;S DIC("S")=DIC("S")_",$G(Y)'=DA(1)"

 +15               SET DIC("S")=DIC("S")_",$G(Y)'=DA(1),$$VGROUP^PXRMDD41($G(Y),DA(1))=0"

               End DoDot:1

 +16       QUIT 

 +17      ;

 +18      ; UPDATE last amend date

SET(DLG)  ;

 +1        SET $PIECE(^PXRMD(801.41,DLG,99),U)=$$NOW^XLFDT

 +2        QUIT 

 +3       ;

 +4       ; -- Ck menu tree to ensure new item is not an ancestor

 +5       ;    Input Xform for Item field #2 of Items subfile #801.412

 +6       ;      expecting DA, DA(1), X from FileMan

TREE      ;

 +1        DO SCREEN

 +2        NEW PXRMDDA,PXRMDD

           SET PXRMDDA=DA(1)

 +3        if X=PXRMDDA

               KILL X

           DO TREE1

 +4        QUIT 

 +5       ; -- Look for X in ancestors

TREE1      FOR PXRMDD=0:0

               if '$DATA(X)

                   QUIT 

               SET PXRMDD=$ORDER(^PXRMD(801.41,"AD",PXRMDDA,PXRMDD))

               if PXRMDD'>0

                   QUIT 

               if X=PXRMDD

                   KILL X

               if '$DATA(X)

                   QUIT 

               DO TREE2

 +1        QUIT 

 +2       ; Back up another level

TREE2      NEW PXRMDDA

           SET PXRMDDA=PXRMDD

           NEW PXRMDD

           DO TREE1

 +1        QUIT 

 +2       ;

VGROUP(DIEN,IEN) ;Check dialog index to see if group will point to itself 

 +1        NEW FOUND

 +2        SET FOUND=0

 +3       ;

 +4       ;Only do check if dialog is a group

 +5        IF $PIECE($GET(^PXRMD(801.41,DIEN,0)),U,4)'="G"

               QUIT FOUND

 +6       ;

 +7       ;Group cannot be added to itself

 +8        IF DIEN=IEN

               SET FOUND=1

               QUIT FOUND

 +9       ;

 +10      ;IEN is the dialog group being added to 

 +11       DO VGROUP1(DIEN,IEN)

 +12       QUIT FOUND

 +13      ;

VGROUP1(DIEN,IEN) ;Examine all parent dialogs

 +1       ;

 +2       ;End search if already found

 +3        if FOUND

               QUIT 

 +4       ;

 +5       ;Check if dialog being added is a parent at this level

 +6        IF $DATA(^PXRMD(801.41,"AD",IEN,DIEN))

               SET FOUND=1

               QUIT 

 +7       ;

 +8       ;If not look at other parents

 +9        NEW SUB,TIEN

 +10       SET SUB=0

 +11       FOR 

               SET SUB=$ORDER(^PXRMD(801.41,"AD",IEN,SUB))

               if 'SUB

                   QUIT 

               Begin DoDot:1

 +12      ;Ignore reminder dialogs

 +13               IF $PIECE($GET(^PXRMD(801.41,SUB,0)),U,4)'="G"

                       QUIT 

 +14      ;Repeat check on other parents

 +15               DO VGROUP1(DIEN,SUB)

               End DoDot:1

               if FOUND

                   QUIT 

 +16       QUIT