PXRMEFM ; SLC/PKR/PJH - Extract Counting Rule Management ;08/03/2006
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
;
;Main entry point for PXRM EXTRACT COUNTING RULES
START(PIEN) ;
N PXRMDONE,VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
S X="IORESET"
D ENDR^%ZISS
S VALMCNT=0
D EN^VALM("PXRM EXTRACT COUNTING RULES")
Q
;
BLDLIST ;Build workfile
K ^TMP("PXRMEFM",$J)
N IEN,IND,PLIST
D LIST(.PLIST,.IEN,PIEN)
M ^TMP("PXRMEFM",$J)=PLIST
S VALMCNT=PLIST("VALMCNT")
F IND=1:1:VALMCNT S ^TMP("PXRMEFM",$J,"IDX",IND,IND)=IEN(IND)
Q
;
ENTRY ;Entry code
D BLDLIST,XQORM
Q
;
EXIT ;Exit code
K ^TMP("PXRMEFM",$J)
K ^TMP("PXRMEFMH",$J)
D CLEAN^VALM10
D FULL^VALM1
S VALMBCK="Q"
Q
;
HDR ; Header code
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
Q
;
HLP ;Help code
N ORU,ORUPRMT,SUB,XQORM
S SUB="PXRMEFMH"
D EN^VALM("PXRM EXTRACT HELP")
Q
;
INIT ;Init
S VALMCNT=0
Q
;
PEXIT ;PXRM EXCH MENU 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 RULE SELECT ENTRY",0))_U_"1:"_VALMCNT
S XQORM("A")="Select Item: "
Q
;
XSEL ;PXRM EXTRACT COUNTING RULE 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("PXRMEFM",$J,"IDX",SEL,SEL)
;Display/Edit Extract Finding
D START^PXRMEFED(IEN)
;
D BLDLIST
;
S VALMBCK="R"
Q
;
HELP(CALL) ;General help text routine
N HTEXT
I CALL=1 D
.S HTEXT(1)="Select DR to display or edit a rule."
.S HTEXT(2)="Select ED to edit a rule"
;
D HELP^PXRMEUT(.HTEXT)
Q
;
EFADD ;Add Rule Option
;
;Reset Screen Mode
W IORESET
;
;Add Rule
D ADD^PXRMEFED
;
;Rebuild Workfile
D BLDLIST
;
S VALMBCK="R"
Q
;
EFINQ ;Extract Finding Inquiry - PXRM EXTRACT FINDINQ DISPLAY/EDIT entry
N IND,FRIEN,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 FRIEN=^TMP("PXRMEFM",$J,"IDX",IND,IND)
.D START^PXRMEFED(FRIEN)
;
D BLDLIST
;
S VALMBCK="R"
Q
;
LIST(RLIST,IEN,PIEN) ;Build a list of extract findings for parameter.
N EPCLASS,IND,FNAME,NAME,PLIST
;Build the list in alphabetical order.
S VALMCNT=0
S NAME=""
F S NAME=$O(^PXRM(810.7,"B",NAME)) Q:NAME="" D
.S IND=$O(^PXRM(810.7,"B",NAME,"")) Q:'IND
.S FNAME=$P($G(^PXRM(810.7,IND,0)),U)
.S EPCLASS=$P($G(^PXRM(810.7,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
;
PXRMEFM ; SLC/PKR/PJH - Extract Counting Rule Management ;08/03/2006
+1 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+2 ;
+3 ;Main entry point for PXRM EXTRACT COUNTING RULES
START(PIEN) ;
+1 NEW PXRMDONE,VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
+2 SET X="IORESET"
+3 DO ENDR^%ZISS
+4 SET VALMCNT=0
+5 DO EN^VALM("PXRM EXTRACT COUNTING RULES")
+6 QUIT
+7 ;
BLDLIST ;Build workfile
+1 KILL ^TMP("PXRMEFM",$JOB)
+2 NEW IEN,IND,PLIST
+3 DO LIST(.PLIST,.IEN,PIEN)
+4 MERGE ^TMP("PXRMEFM",$JOB)=PLIST
+5 SET VALMCNT=PLIST("VALMCNT")
+6 FOR IND=1:1:VALMCNT
SET ^TMP("PXRMEFM",$JOB,"IDX",IND,IND)=IEN(IND)
+7 QUIT
+8 ;
ENTRY ;Entry code
+1 DO BLDLIST
DO XQORM
+2 QUIT
+3 ;
EXIT ;Exit code
+1 KILL ^TMP("PXRMEFM",$JOB)
+2 KILL ^TMP("PXRMEFMH",$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"
+2 QUIT
+3 ;
HLP ;Help code
+1 NEW ORU,ORUPRMT,SUB,XQORM
+2 SET SUB="PXRMEFMH"
+3 DO EN^VALM("PXRM EXTRACT HELP")
+4 QUIT
+5 ;
INIT ;Init
+1 SET VALMCNT=0
+2 QUIT
+3 ;
PEXIT ;PXRM EXCH MENU 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 RULE SELECT ENTRY",0))_U_"1:"_VALMCNT
+1 SET XQORM("A")="Select Item: "
+2 QUIT
+3 ;
XSEL ;PXRM EXTRACT COUNTING RULE 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("PXRMEFM",$JOB,"IDX",SEL,SEL)
+15 ;Display/Edit Extract Finding
+16 DO START^PXRMEFED(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 DR 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 ;
EFADD ;Add Rule Option
+1 ;
+2 ;Reset Screen Mode
+3 WRITE IORESET
+4 ;
+5 ;Add Rule
+6 DO ADD^PXRMEFED
+7 ;
+8 ;Rebuild Workfile
+9 DO BLDLIST
+10 ;
+11 SET VALMBCK="R"
+12 QUIT
+13 ;
EFINQ ;Extract Finding Inquiry - PXRM EXTRACT FINDINQ DISPLAY/EDIT entry
+1 NEW IND,FRIEN,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 FRIEN=^TMP("PXRMEFM",$JOB,"IDX",IND,IND)
+11 DO START^PXRMEFED(FRIEN)
End DoDot:1
+12 ;
+13 DO BLDLIST
+14 ;
+15 SET VALMBCK="R"
+16 QUIT
+17 ;
LIST(RLIST,IEN,PIEN) ;Build a list of extract findings for parameter.
+1 NEW EPCLASS,IND,FNAME,NAME,PLIST
+2 ;Build the list in alphabetical order.
+3 SET VALMCNT=0
+4 SET NAME=""
+5 FOR
SET NAME=$ORDER(^PXRM(810.7,"B",NAME))
IF NAME=""
QUIT
Begin DoDot:1
+6 SET IND=$ORDER(^PXRM(810.7,"B",NAME,""))
IF 'IND
QUIT
+7 SET FNAME=$PIECE($GET(^PXRM(810.7,IND,0)),U)
+8 SET EPCLASS=$PIECE($GET(^PXRM(810.7,IND,100)),U)
+9 SET VALMCNT=VALMCNT+1
+10 SET RLIST(VALMCNT,0)=$$FRE(VALMCNT,FNAME,EPCLASS)
+11 SET IEN(VALMCNT)=IND
End DoDot:1
+12 SET RLIST("VALMCNT")=VALMCNT
+13 QUIT
+14 ;
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 ;
