PXRMEGM.m

PXRMEGM ; SLC/PKR/PJH - Extract Counting Group Management ;08/03/2006

 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21

 ;

 ;Main entry point for PXRM EXTRACT COUNTING GROUPS

START(EFIEN) ;

 N EFCLASS,EFNAME,PXRMDONE,GROUP

 N VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD

 S X="IORESET"

 D ENDR^%ZISS

 S VALMCNT=0

 I EFIEN D

 .S EFNAME=$P($G(^PXRM(810.7,EFIEN,0)),U)

 .S EFCLASS=$P($G(^PXRM(810.7,EFIEN,100)),U)

 .S EFCLASS=$S(EFCLASS="N":"National",EFCLASS="V":"VISN",1:"Local")

 D EN^VALM("PXRM EXTRACT COUNTING GROUPS")

 Q

 ;

BLDLIST ;Build workfile

 K ^TMP("PXRMEGM",$J)

 N IEN,IND,PLIST

 D LIST(.PLIST,.IEN,EFIEN)

 M ^TMP("PXRMEGM",$J)=PLIST

 S VALMCNT=PLIST("VALMCNT")

 F IND=1:1:VALMCNT D

 .S ^TMP("PXRMEGM",$J,"IDX",IND,IND)=IEN(IND)

 Q

 ;

ENTRY ;Entry code

 D BLDLIST,XQORM

 Q

 ;

EXIT ;Exit code

 K ^TMP("PXRMEGM",$J)

 K ^TMP("PXRMEGMH",$J)

 D CLEAN^VALM10

 D FULL^VALM1

 S VALMBCK="Q"

 Q

 ;

HDR ; Header code

 S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions" Q:'EFIEN

 S VALMHDR(1)="Extract Finding: "_EFNAME

 S VALMHDR(2)="          Class: "_EFCLASS

 Q

 ;

HLP ;Help code

 N ORU,ORUPRMT,SUB,XQORM

 S SUB="PXRMEGMH"

 D EN^VALM("PXRM EXTRACT HELP")

 Q

 ;

INIT ;Init

 S VALMCNT=0

 Q

 ;

PEXIT ;Protocol exit code

 S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"

 ;Reset after page up/down etc

 D XQORM

 Q

 ;

XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXTRACT COUNTING GROUP SELECT ENTRY",0))_U_"1:"_VALMCNT

 S XQORM("A")="Select Item: "

 Q

 ;

XSEL ;PXRM EXTRACT COUNTING GROUP SELECT ENTRY validation

 N SEL,IEN

 S SEL=$P(XQORNOD(0),"=",2)

 ;Remove trailing ,

 I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)

 ;Invalid selection

 I SEL["," D  Q

 .W $C(7),!,"Only one item number allowed." H 2

 .S VALMBCK="R"

 I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("IDX",SEL))) D  Q

 .W $C(7),!,SEL_" is not a valid item number." H 2

 .S VALMBCK="R"

 ;

 ;Get the list ien.

 S IEN=^TMP("PXRMEGM",$J,"IDX",SEL,SEL)

 ;Display/Edit Extract Counting Group

 D START^PXRMEGED(IEN)

 ;

 D BLDLIST

 ;

 S VALMBCK="R"

 Q

 ;

HELP(CALL) ;General help text routine

 N HTEXT

 I CALL=1 D

 .S HTEXT(1)="Select DE to display or edit a rule."

 .S HTEXT(2)="Select ED to edit a rule"

 ;

 D HELP^PXRMEUT(.HTEXT)

 Q

 ;

EGADD ;Add Rule Option

 ;

 ;Reset Screen Mode

 W IORESET

 ;

 ;Add Rule

 D ADD^PXRMEGED

 ;

 ;Rebuild Workfile

 D BLDLIST

 ;

 S VALMBCK="R"

 Q

 ;

EGINQ ;Counting Group Inquiry - PXRM EXTRACT COUNTING GROUP DISPLAY/EDIT entry 

 N IND,FGIEN,VALMY

 D EN^VALM2(XQORNOD(0))

 ;

 ;If there is no list quit.

 I '$D(VALMY) Q

 S PXRMDONE=0

 S IND=""

 F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D

 .;Get the ien.

 .S FGIEN=^TMP("PXRMEGM",$J,"IDX",IND,IND)

 .D START^PXRMEGED(FGIEN)

 ;

 D BLDLIST

 ;

 S VALMBCK="R"

 Q

 ;

LIST(RLIST,IEN,EFIEN) ;Build a list of extract counting groups for 

 ;extract definition.

 N EPCLASS,IND,FNAME,NAME,PLIST

 ;If called for a selected extract finding build list of groups

 I EFIEN D

 .N SUB,FGIEN

 .S SUB=0

 .F  S SUB=$O(^PXRM(810.7,EFIEN,10,SUB)) Q:'SUB  D

 ..S FGIEN=$P($G(^PXRM(810.7,EFIEN,10,SUB,0)),U,2) Q:'FGIEN

 ..S GROUP(FGIEN)=""

 ;

 ;Build the list in alphabetical order.

 S VALMCNT=0

 S NAME=""

 F  S NAME=$O(^PXRM(810.8,"B",NAME)) Q:NAME=""  D

 .S IND=$O(^PXRM(810.8,"B",NAME,"")) Q:'IND

 .;For extract counting rule only include finding counting groups

 .I EFIEN,'$D(GROUP(IND)) Q

 .S FNAME=$P($G(^PXRM(810.8,IND,0)),U)

 .S EPCLASS=$P($G(^PXRM(810.8,IND,100)),U)

 .S VALMCNT=VALMCNT+1

 .S RLIST(VALMCNT,0)=$$FRE(VALMCNT,FNAME,EPCLASS)

 .S IEN(VALMCNT)=IND

 S RLIST("VALMCNT")=VALMCNT

 Q

 ;

FRE(NUMBER,NAME,CLASS) ;Format  entry number, name

 ;and date packed.

 N TCLASS,TEMP,TNAME,TSOURCE

 S TEMP=$$RJ^XLFSTR(NUMBER,5," ")

 S TNAME=$E(NAME,1,46)

 S TEMP=TEMP_"  "_$$LJ^XLFSTR(TNAME,60," ")

 S TCLASS=$S(CLASS="N":"NATIONAL",CLASS="V":"VISN",1:"LOCAL")

 S TEMP=TEMP_"  "_TCLASS

 Q TEMP

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PXRMEGM   3995     printed  Mar 13, 2025@20:49:08                                                                                                                                                                                                     Page 2

PXRMEGM   ; SLC/PKR/PJH - Extract Counting Group Management ;08/03/2006

 +1       ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21

 +2       ;

 +3       ;Main entry point for PXRM EXTRACT COUNTING GROUPS

START(EFIEN) ;

 +1        NEW EFCLASS,EFNAME,PXRMDONE,GROUP

 +2        NEW VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD

 +3        SET X="IORESET"

 +4        DO ENDR^%ZISS

 +5        SET VALMCNT=0

 +6        IF EFIEN

               Begin DoDot:1

 +7                SET EFNAME=$PIECE($GET(^PXRM(810.7,EFIEN,0)),U)

 +8                SET EFCLASS=$PIECE($GET(^PXRM(810.7,EFIEN,100)),U)

 +9                SET EFCLASS=$SELECT(EFCLASS="N":"National",EFCLASS="V":"VISN",1:"Local")

               End DoDot:1

 +10       DO EN^VALM("PXRM EXTRACT COUNTING GROUPS")

 +11       QUIT 

 +12      ;

BLDLIST   ;Build workfile

 +1        KILL ^TMP("PXRMEGM",$JOB)

 +2        NEW IEN,IND,PLIST

 +3        DO LIST(.PLIST,.IEN,EFIEN)

 +4        MERGE ^TMP("PXRMEGM",$JOB)=PLIST

 +5        SET VALMCNT=PLIST("VALMCNT")

 +6        FOR IND=1:1:VALMCNT

               Begin DoDot:1

 +7                SET ^TMP("PXRMEGM",$JOB,"IDX",IND,IND)=IEN(IND)

               End DoDot:1

 +8        QUIT 

 +9       ;

ENTRY     ;Entry code

 +1        DO BLDLIST

           DO XQORM

 +2        QUIT 

 +3       ;

EXIT      ;Exit code

 +1        KILL ^TMP("PXRMEGM",$JOB)

 +2        KILL ^TMP("PXRMEGMH",$JOB)

 +3        DO CLEAN^VALM10

 +4        DO FULL^VALM1

 +5        SET VALMBCK="Q"

 +6        QUIT 

 +7       ;

HDR       ; Header code

 +1        SET VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"

           if 'EFIEN

               QUIT 

 +2        SET VALMHDR(1)="Extract Finding: "_EFNAME

 +3        SET VALMHDR(2)="          Class: "_EFCLASS

 +4        QUIT 

 +5       ;

HLP       ;Help code

 +1        NEW ORU,ORUPRMT,SUB,XQORM

 +2        SET SUB="PXRMEGMH"

 +3        DO EN^VALM("PXRM EXTRACT HELP")

 +4        QUIT 

 +5       ;

INIT      ;Init

 +1        SET VALMCNT=0

 +2        QUIT 

 +3       ;

PEXIT     ;Protocol exit code

 +1        SET VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"

 +2       ;Reset after page up/down etc

 +3        DO XQORM

 +4        QUIT 

 +5       ;

XQORM      SET XQORM("#")=$ORDER(^ORD(101,"B","PXRM EXTRACT COUNTING GROUP SELECT ENTRY",0))_U_"1:"_VALMCNT

 +1        SET XQORM("A")="Select Item: "

 +2        QUIT 

 +3       ;

XSEL      ;PXRM EXTRACT COUNTING GROUP SELECT ENTRY validation

 +1        NEW SEL,IEN

 +2        SET SEL=$PIECE(XQORNOD(0),"=",2)

 +3       ;Remove trailing ,

 +4        IF $EXTRACT(SEL,$LENGTH(SEL))=","

               SET SEL=$EXTRACT(SEL,1,$LENGTH(SEL)-1)

 +5       ;Invalid selection

 +6        IF SEL[","

               Begin DoDot:1

 +7                WRITE $CHAR(7),!,"Only one item number allowed."

                   HANG 2

 +8                SET VALMBCK="R"

               End DoDot:1

               QUIT 

 +9        IF ('SEL)!(SEL>VALMCNT)!('$DATA(@VALMAR@("IDX",SEL)))

               Begin DoDot:1

 +10               WRITE $CHAR(7),!,SEL_" is not a valid item number."

                   HANG 2

 +11               SET VALMBCK="R"

               End DoDot:1

               QUIT 

 +12      ;

 +13      ;Get the list ien.

 +14       SET IEN=^TMP("PXRMEGM",$JOB,"IDX",SEL,SEL)

 +15      ;Display/Edit Extract Counting Group

 +16       DO START^PXRMEGED(IEN)

 +17      ;

 +18       DO BLDLIST

 +19      ;

 +20       SET VALMBCK="R"

 +21       QUIT 

 +22      ;

HELP(CALL) ;General help text routine

 +1        NEW HTEXT

 +2        IF CALL=1

               Begin DoDot:1

 +3                SET HTEXT(1)="Select DE to display or edit a rule."

 +4                SET HTEXT(2)="Select ED to edit a rule"

               End DoDot:1

 +5       ;

 +6        DO HELP^PXRMEUT(.HTEXT)

 +7        QUIT 

 +8       ;

EGADD     ;Add Rule Option

 +1       ;

 +2       ;Reset Screen Mode

 +3        WRITE IORESET

 +4       ;

 +5       ;Add Rule

 +6        DO ADD^PXRMEGED

 +7       ;

 +8       ;Rebuild Workfile

 +9        DO BLDLIST

 +10      ;

 +11       SET VALMBCK="R"

 +12       QUIT 

 +13      ;

EGINQ     ;Counting Group Inquiry - PXRM EXTRACT COUNTING GROUP DISPLAY/EDIT entry 

 +1        NEW IND,FGIEN,VALMY

 +2        DO EN^VALM2(XQORNOD(0))

 +3       ;

 +4       ;If there is no list quit.

 +5        IF '$DATA(VALMY)

               QUIT 

 +6        SET PXRMDONE=0

 +7        SET IND=""

 +8        FOR 

               SET IND=$ORDER(VALMY(IND))

               if (+IND=0)!(PXRMDONE)

                   QUIT 

               Begin DoDot:1

 +9       ;Get the ien.

 +10               SET FGIEN=^TMP("PXRMEGM",$JOB,"IDX",IND,IND)

 +11               DO START^PXRMEGED(FGIEN)

               End DoDot:1

 +12      ;

 +13       DO BLDLIST

 +14      ;

 +15       SET VALMBCK="R"

 +16       QUIT 

 +17      ;

LIST(RLIST,IEN,EFIEN) ;Build a list of extract counting groups for 

 +1       ;extract definition.

 +2        NEW EPCLASS,IND,FNAME,NAME,PLIST

 +3       ;If called for a selected extract finding build list of groups

 +4        IF EFIEN

               Begin DoDot:1

 +5                NEW SUB,FGIEN

 +6                SET SUB=0

 +7                FOR 

                       SET SUB=$ORDER(^PXRM(810.7,EFIEN,10,SUB))

                       if 'SUB

                           QUIT 

                       Begin DoDot:2

 +8                        SET FGIEN=$PIECE($GET(^PXRM(810.7,EFIEN,10,SUB,0)),U,2)

                           if 'FGIEN

                               QUIT 

 +9                        SET GROUP(FGIEN)=""

                       End DoDot:2

               End DoDot:1

 +10      ;

 +11      ;Build the list in alphabetical order.

 +12       SET VALMCNT=0

 +13       SET NAME=""

 +14       FOR 

               SET NAME=$ORDER(^PXRM(810.8,"B",NAME))

               if NAME=""

                   QUIT 

               Begin DoDot:1

 +15               SET IND=$ORDER(^PXRM(810.8,"B",NAME,""))

                   if 'IND

                       QUIT 

 +16      ;For extract counting rule only include finding counting groups

 +17               IF EFIEN

                       IF '$DATA(GROUP(IND))

                           QUIT 

 +18               SET FNAME=$PIECE($GET(^PXRM(810.8,IND,0)),U)

 +19               SET EPCLASS=$PIECE($GET(^PXRM(810.8,IND,100)),U)

 +20               SET VALMCNT=VALMCNT+1

 +21               SET RLIST(VALMCNT,0)=$$FRE(VALMCNT,FNAME,EPCLASS)

 +22               SET IEN(VALMCNT)=IND

               End DoDot:1

 +23       SET RLIST("VALMCNT")=VALMCNT

 +24       QUIT 

 +25      ;

FRE(NUMBER,NAME,CLASS) ;Format  entry number, name

 +1       ;and date packed.

 +2        NEW TCLASS,TEMP,TNAME,TSOURCE

 +3        SET TEMP=$$RJ^XLFSTR(NUMBER,5," ")

 +4        SET TNAME=$EXTRACT(NAME,1,46)

 +5        SET TEMP=TEMP_"  "_$$LJ^XLFSTR(TNAME,60," ")

 +6        SET TCLASS=$SELECT(CLASS="N":"NATIONAL",CLASS="V":"VISN",1:"LOCAL")

 +7        SET TEMP=TEMP_"  "_TCLASS

 +8        QUIT TEMP

 +9       ;