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 ---[H[J[2J[HPXRMEGM 3995 printed Oct 16, 2024@17:45:20 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 ;
