PXRMETT ; SLC/PJH - Extract Summary Display ;04/09/2007
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
;
;Main entry point for PXRM EXTRACT SUMMARY
START(IEN) N TOGGLE,TOGGLE1,VALMBCK,VALMBG,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
S X="IORESET"
D ENDR^%ZISS
S VALMCNT=0,TOGGLE=0,TOGGLE1=0
D EN^VALM("PXRM EXTRACT SUMMARY")
Q
;
BLDLIST(IEN,FINDINGS,PATIENT) ;Build workfile.
;FINDINGS=1 means display finding totals
K ^TMP("PXRMETT",$J)
;Build a list of extract summary totals.
N APPL,DATA,DUE,IND,LIST,NDUE,NAPPL,OLIST
N PLCNT,PLIST,RIEN,RNAME,SARRAY,SEQ,SNAME,STATION,TOT
;Build the list in alphabetical order.
S VALMCNT=0,OLIST="",PLCNT=0
S IND=0 F S IND=$O(^PXRMXT(810.3,IEN,3,IND)) Q:IND'>0 D
.S DATA=$G(^PXRMXT(810.3,IEN,3,IND,0)) Q:DATA=""
.S RIEN=$P(DATA,U,2) Q:'RIEN
.S RNAME=$P(^PXD(811.9,RIEN,0),U,3)
.I RNAME="" S RNAME=$P(^PXD(811.9,RIEN,0),U,1)
.S STATION=$P(DATA,U,3),SARRAY=""
.D GETS^DIQ(4,STATION,99,"E","SARRAY")
.S SNAME=$G(SARRAY(4,STATION_",",99,"E"))
.I SNAME="" S SNAME=STATION
.S TOT=+$P(DATA,U,5),APPL=+$P(DATA,U,6),NAPPL=+$P(DATA,U,7)
.S DUE=+$P(DATA,U,8),NDUE=+$P(DATA,U,9)
.S PLIST=$P(DATA,U,4)
.I PLIST,PLIST'=OLIST D
..I PLCNT>0 D
...S VALMCNT=VALMCNT+1
...S ^TMP("PXRMETT",$J,VALMCNT,0)=""
...S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
..S PLNAME=$P($G(^PXRMXP(810.5,PLIST,0)),U),OLIST=PLIST Q:PLNAME=""
..S VALMCNT=VALMCNT+1,PLCNT=PLCNT+1
..S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
..S ^TMP("PXRMETT",$J,"SEL",PLCNT)=PLIST
..S ^TMP("PXRMETT",$J,VALMCNT,0)=$$RJ^XLFSTR(PLCNT,4," ")_" "_PLNAME
.S VALMCNT=VALMCNT+1
.S ^TMP("PXRMETT",$J,VALMCNT,0)=$$FRE(VALMCNT,RNAME,SNAME,TOT,APPL,NAPPL,DUE,NDUE)
.S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
.;Finding totals
.I +FINDINGS>0 D FBLD(PATIENT)
;
S ^TMP("PXRMETT",$J,"VALMCNT")=VALMCNT
Q
;
ENTRY ;Entry code
D BLDLIST(IEN,TOGGLE,TOGGLE1),XQORM
Q
;
EXIT ;Exit code
K ^TMP("PXRMETT",$J)
K ^TMP("PXRMETTH",$J)
D CLEAN^VALM10
D FULL^VALM1
S VALMBCK="Q"
Q
;
FBLD(PATIENT) ;Build finding list
N APPL,DATA,DUE,ETYP,EVAL,GNAM,GTYP
N NAPPL,NDUE,OGNAM,SEQ,SUB,TIEN,TNAME,TOTAL
S SUB=0,OGNAM=""
F S SUB=$O(^PXRMXT(810.3,IEN,3,IND,1,SUB)) Q:'SUB D
.S DATA=$G(^PXRMXT(810.3,IEN,3,IND,1,SUB,0)) Q:DATA=""
.S TIEN=$P(DATA,U,2) Q:'TIEN
.S TNAME=$P($G(^PXRMD(811.5,TIEN,0)),U)
.S SEQ=$P(DATA,U),ETYP=$P(DATA,U,3),GNAM=$P(DATA,U,9),GTYP=$P(DATA,U,10)
.S TOT=+$P(DATA,U,4),APPL=+$P(DATA,U,5),NAPPL=+$P(DATA,U,6)
.S DUE=+$P(DATA,U,7),NDUE=+$P(DATA,U,8)
.I OGNAM'=GNAM D
..I OGNAM'="" D
...S VALMCNT=VALMCNT+1
...S ^TMP("PXRMETT",$J,VALMCNT,0)=""
...S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
..S OGNAM=GNAM,VALMCNT=VALMCNT+1
..S ^TMP("PXRMETT",$J,VALMCNT,0)=$$RJ^XLFSTR("Counting Group: ",21)_GNAM
..S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)="",VALMCNT=VALMCNT+1
..S ^TMP("PXRMETT",$J,VALMCNT,0)=$J("",6)_$$LJ^XLFSTR($$TXT^PXRMEPM(ETYP,GTYP),49)
..S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
.S VALMCNT=VALMCNT+1
.S ^TMP("PXRMETT",$J,VALMCNT,0)=$$FREF(VALMCNT,TNAME,SEQ,TOT,APPL,NAPPL,DUE,NDUE,ETYP)
.S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
.I +PATIENT>0 D PBLD(IEN,IND,SUB)
S VALMCNT=VALMCNT+1
S ^TMP("PXRMETT",$J,VALMCNT,0)=""
S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
Q
;
FLIST ;Toggle list with/without finding totals
S TOGGLE=(TOGGLE+1)#2
I TOGGLE=0 S TOGGLE1=0
;Rebuild Workfile
D BLDLIST(IEN,TOGGLE,TOGGLE1)
;Refresh
S VALMBCK="R",VALMBG=1
Q
;
FRE(NUMBER,NAME,SNAME,TOT,APPL,NAPPL,DUE,NDUE) ;Format reminder entry
N TEMP,TNAME,TSOURCE
S TEMP=" "
S TNAME=SNAME_"/"_$E(NAME,1,35-$L(SNAME))
S TEMP=TEMP_$$LJ^XLFSTR(TNAME,36," ")
S TEMP=TEMP_$$RJ^XLFSTR(TOT,8," ")
S TEMP=TEMP_$$RJ^XLFSTR(APPL,8," ")
S TEMP=TEMP_$$RJ^XLFSTR(NAPPL,7," ")
S TEMP=TEMP_$$RJ^XLFSTR(DUE,7," ")
S TEMP=TEMP_$$RJ^XLFSTR(NDUE,7," ")
Q TEMP
;
FREF(NUMBER,NAME,SNAME,TOT,APPL,NAPPL,DUE,NDUE,ETYP) ;Format finding entry
N TEMP,TNAME,TSOURCE
S TEMP=" "
S TNAME=$E(NAME,1,31)
S TEMP=TEMP_" "_$$LJ^XLFSTR(TNAME,31," ")
S TEMP=TEMP_" "_$$RJ^XLFSTR(TOT,8," ")
I ETYP'="FC" D
.S TEMP=TEMP_$$RJ^XLFSTR(APPL,8," ")
.S TEMP=TEMP_$$RJ^XLFSTR(NAPPL,7," ")
.S TEMP=TEMP_$$RJ^XLFSTR(DUE,7," ")
.S TEMP=TEMP_$$RJ^XLFSTR(NDUE,7," ")
Q TEMP
;
HDR ; Header code
S VALMHDR(1)="Extract Summary Name: "_$P($G(^PXRMXT(810.3,IEN,0)),U)
S VALMHDR(2)=" Extract Period: "_$$FMTE^XLFDT($P($G(^PXRMXT(810.3,IEN,0)),U,2),"5Z")_" - "_$$FMTE^XLFDT($P($G(^PXRMXT(810.3,IEN,0)),U,3),"5Z")
S VALMHDR(2)=VALMHDR(2)_" Created: "_$$FMTE^XLFDT($P($G(^PXRMXT(810.3,IEN,0)),U,6),"5Z")
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
Q
;
HLP ;Help code
N ORU,ORUPRMT,XQORM
S SUB="PXRMETTH"
D EN^VALM("PXRM EXTRACT HELP")
Q
;
INIT ;Init
S VALMCNT=0
Q
;
PBLD(IEN,IND,SUB) ;
N ARRAY,NAME,LEN,PCNT,DFN,CNT,USTR
S VALMCNT=VALMCNT+1,CNT=0
S PCNT=0 F S PCNT=$O(^PXRMXT(810.3,IEN,3,IND,1,SUB,1,PCNT)) Q:PCNT'>0 D
.S DFN=$P($G(^PXRMXT(810.3,IEN,3,IND,1,SUB,1,PCNT,0)),U) Q:DFN'>0
.S NAME=$P($G(^DPT(DFN,0)),U)
.S CNT=CNT+1,ARRAY(NAME)=""
S ^TMP("PXRMETT",$J,VALMCNT,0)=" "_$$RJ^XLFSTR("Unique Applicable Patients ("_CNT_")",36," ")
S USTR=$P($G(^TMP("PXRMETT",$J,VALMCNT,0)),"U"),LEN=$L(USTR)
S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
S NAME="" F S NAME=$O(ARRAY(NAME)) Q:NAME="" D
.S VALMCNT=VALMCNT+1
.S ^TMP("PXRMETT",$J,VALMCNT,0)=USTR_$$LJ^XLFSTR(NAME,36," ")
.S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
S VALMCNT=VALMCNT+1
S ^TMP("PXRMETT",$J,VALMCNT,0)=" "
S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
Q
;
PEXIT ;Protocol exit code
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
D XQORM
Q
;
PLIST(IEN) ;Patient list display
N IND,PLIEN,VALMY
D EN^VALM2(XQORNOD(0))
;If there is no list quit.
I '$D(VALMY) Q
;PXRMDONE is newed in PXRMLPM
S PXRMDONE=0
S IND=""
F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D
.;Get the ien.
.S PLIEN=^TMP("PXRMETT",$J,"SEL",IND)
.D START^PXRMLPP(PLIEN)
S VALMBCK="R"
Q
;
PLIST1 ;Toggle list with/without finding totals
S TOGGLE1=(TOGGLE1+1)#2
;Rebuild Workfile
D BLDLIST(IEN,TOGGLE,TOGGLE1)
;Refresh
S VALMBCK="R",VALMBG=1
Q
;
XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXTRACT SUMMARY SELECT ENTRY",0))_U_"1:"_VALMCNT
S XQORM("A")="Select Item: "
Q
;
XSEL ;PXRM EXTRACT TOTALS SELECT ENTRY validation
N SEL,PLIEN
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@("SEL",SEL))) D Q
.W $C(7),!,SEL_" is not a valid item number." H 2
.S VALMBCK="R"
;Get the list ien.
S PLIEN=^TMP("PXRMETT",$J,"SEL",SEL)
D START^PXRMLPP(PLIEN)
S VALMBCK="R"
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMETT 6917 printed Dec 13, 2024@01:44:41 Page 2
PXRMETT ; SLC/PJH - Extract Summary Display ;04/09/2007
+1 ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+2 ;
+3 ;Main entry point for PXRM EXTRACT SUMMARY
START(IEN) NEW TOGGLE,TOGGLE1,VALMBCK,VALMBG,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
+1 SET X="IORESET"
+2 DO ENDR^%ZISS
+3 SET VALMCNT=0
SET TOGGLE=0
SET TOGGLE1=0
+4 DO EN^VALM("PXRM EXTRACT SUMMARY")
+5 QUIT
+6 ;
BLDLIST(IEN,FINDINGS,PATIENT) ;Build workfile.
+1 ;FINDINGS=1 means display finding totals
+2 KILL ^TMP("PXRMETT",$JOB)
+3 ;Build a list of extract summary totals.
+4 NEW APPL,DATA,DUE,IND,LIST,NDUE,NAPPL,OLIST
+5 NEW PLCNT,PLIST,RIEN,RNAME,SARRAY,SEQ,SNAME,STATION,TOT
+6 ;Build the list in alphabetical order.
+7 SET VALMCNT=0
SET OLIST=""
SET PLCNT=0
+8 SET IND=0
FOR
SET IND=$ORDER(^PXRMXT(810.3,IEN,3,IND))
if IND'>0
QUIT
Begin DoDot:1
+9 SET DATA=$GET(^PXRMXT(810.3,IEN,3,IND,0))
if DATA=""
QUIT
+10 SET RIEN=$PIECE(DATA,U,2)
if 'RIEN
QUIT
+11 SET RNAME=$PIECE(^PXD(811.9,RIEN,0),U,3)
+12 IF RNAME=""
SET RNAME=$PIECE(^PXD(811.9,RIEN,0),U,1)
+13 SET STATION=$PIECE(DATA,U,3)
SET SARRAY=""
+14 DO GETS^DIQ(4,STATION,99,"E","SARRAY")
+15 SET SNAME=$GET(SARRAY(4,STATION_",",99,"E"))
+16 IF SNAME=""
SET SNAME=STATION
+17 SET TOT=+$PIECE(DATA,U,5)
SET APPL=+$PIECE(DATA,U,6)
SET NAPPL=+$PIECE(DATA,U,7)
+18 SET DUE=+$PIECE(DATA,U,8)
SET NDUE=+$PIECE(DATA,U,9)
+19 SET PLIST=$PIECE(DATA,U,4)
+20 IF PLIST
IF PLIST'=OLIST
Begin DoDot:2
+21 IF PLCNT>0
Begin DoDot:3
+22 SET VALMCNT=VALMCNT+1
+23 SET ^TMP("PXRMETT",$JOB,VALMCNT,0)=""
+24 SET ^TMP("PXRMETT",$JOB,"IDX",VALMCNT,PLCNT)=""
End DoDot:3
+25 SET PLNAME=$PIECE($GET(^PXRMXP(810.5,PLIST,0)),U)
SET OLIST=PLIST
if PLNAME=""
QUIT
+26 SET VALMCNT=VALMCNT+1
SET PLCNT=PLCNT+1
+27 SET ^TMP("PXRMETT",$JOB,"IDX",VALMCNT,PLCNT)=""
+28 SET ^TMP("PXRMETT",$JOB,"SEL",PLCNT)=PLIST
+29 SET ^TMP("PXRMETT",$JOB,VALMCNT,0)=$$RJ^XLFSTR(PLCNT,4," ")_" "_PLNAME
End DoDot:2
+30 SET VALMCNT=VALMCNT+1
+31 SET ^TMP("PXRMETT",$JOB,VALMCNT,0)=$$FRE(VALMCNT,RNAME,SNAME,TOT,APPL,NAPPL,DUE,NDUE)
+32 SET ^TMP("PXRMETT",$JOB,"IDX",VALMCNT,PLCNT)=""
+33 ;Finding totals
+34 IF +FINDINGS>0
DO FBLD(PATIENT)
End DoDot:1
+35 ;
+36 SET ^TMP("PXRMETT",$JOB,"VALMCNT")=VALMCNT
+37 QUIT
+38 ;
ENTRY ;Entry code
+1 DO BLDLIST(IEN,TOGGLE,TOGGLE1)
DO XQORM
+2 QUIT
+3 ;
EXIT ;Exit code
+1 KILL ^TMP("PXRMETT",$JOB)
+2 KILL ^TMP("PXRMETTH",$JOB)
+3 DO CLEAN^VALM10
+4 DO FULL^VALM1
+5 SET VALMBCK="Q"
+6 QUIT
+7 ;
FBLD(PATIENT) ;Build finding list
+1 NEW APPL,DATA,DUE,ETYP,EVAL,GNAM,GTYP
+2 NEW NAPPL,NDUE,OGNAM,SEQ,SUB,TIEN,TNAME,TOTAL
+3 SET SUB=0
SET OGNAM=""
+4 FOR
SET SUB=$ORDER(^PXRMXT(810.3,IEN,3,IND,1,SUB))
if 'SUB
QUIT
Begin DoDot:1
+5 SET DATA=$GET(^PXRMXT(810.3,IEN,3,IND,1,SUB,0))
if DATA=""
QUIT
+6 SET TIEN=$PIECE(DATA,U,2)
if 'TIEN
QUIT
+7 SET TNAME=$PIECE($GET(^PXRMD(811.5,TIEN,0)),U)
+8 SET SEQ=$PIECE(DATA,U)
SET ETYP=$PIECE(DATA,U,3)
SET GNAM=$PIECE(DATA,U,9)
SET GTYP=$PIECE(DATA,U,10)
+9 SET TOT=+$PIECE(DATA,U,4)
SET APPL=+$PIECE(DATA,U,5)
SET NAPPL=+$PIECE(DATA,U,6)
+10 SET DUE=+$PIECE(DATA,U,7)
SET NDUE=+$PIECE(DATA,U,8)
+11 IF OGNAM'=GNAM
Begin DoDot:2
+12 IF OGNAM'=""
Begin DoDot:3
+13 SET VALMCNT=VALMCNT+1
+14 SET ^TMP("PXRMETT",$JOB,VALMCNT,0)=""
+15 SET ^TMP("PXRMETT",$JOB,"IDX",VALMCNT,PLCNT)=""
End DoDot:3
+16 SET OGNAM=GNAM
SET VALMCNT=VALMCNT+1
+17 SET ^TMP("PXRMETT",$JOB,VALMCNT,0)=$$RJ^XLFSTR("Counting Group: ",21)_GNAM
+18 SET ^TMP("PXRMETT",$JOB,"IDX",VALMCNT,PLCNT)=""
SET VALMCNT=VALMCNT+1
+19 SET ^TMP("PXRMETT",$JOB,VALMCNT,0)=$JUSTIFY("",6)_$$LJ^XLFSTR($$TXT^PXRMEPM(ETYP,GTYP),49)
+20 SET ^TMP("PXRMETT",$JOB,"IDX",VALMCNT,PLCNT)=""
End DoDot:2
+21 SET VALMCNT=VALMCNT+1
+22 SET ^TMP("PXRMETT",$JOB,VALMCNT,0)=$$FREF(VALMCNT,TNAME,SEQ,TOT,APPL,NAPPL,DUE,NDUE,ETYP)
+23 SET ^TMP("PXRMETT",$JOB,"IDX",VALMCNT,PLCNT)=""
+24 IF +PATIENT>0
DO PBLD(IEN,IND,SUB)
End DoDot:1
+25 SET VALMCNT=VALMCNT+1
+26 SET ^TMP("PXRMETT",$JOB,VALMCNT,0)=""
+27 SET ^TMP("PXRMETT",$JOB,"IDX",VALMCNT,PLCNT)=""
+28 QUIT
+29 ;
FLIST ;Toggle list with/without finding totals
+1 SET TOGGLE=(TOGGLE+1)#2
+2 IF TOGGLE=0
SET TOGGLE1=0
+3 ;Rebuild Workfile
+4 DO BLDLIST(IEN,TOGGLE,TOGGLE1)
+5 ;Refresh
+6 SET VALMBCK="R"
SET VALMBG=1
+7 QUIT
+8 ;
FRE(NUMBER,NAME,SNAME,TOT,APPL,NAPPL,DUE,NDUE) ;Format reminder entry
+1 NEW TEMP,TNAME,TSOURCE
+2 SET TEMP=" "
+3 SET TNAME=SNAME_"/"_$EXTRACT(NAME,1,35-$LENGTH(SNAME))
+4 SET TEMP=TEMP_$$LJ^XLFSTR(TNAME,36," ")
+5 SET TEMP=TEMP_$$RJ^XLFSTR(TOT,8," ")
+6 SET TEMP=TEMP_$$RJ^XLFSTR(APPL,8," ")
+7 SET TEMP=TEMP_$$RJ^XLFSTR(NAPPL,7," ")
+8 SET TEMP=TEMP_$$RJ^XLFSTR(DUE,7," ")
+9 SET TEMP=TEMP_$$RJ^XLFSTR(NDUE,7," ")
+10 QUIT TEMP
+11 ;
FREF(NUMBER,NAME,SNAME,TOT,APPL,NAPPL,DUE,NDUE,ETYP) ;Format finding entry
+1 NEW TEMP,TNAME,TSOURCE
+2 SET TEMP=" "
+3 SET TNAME=$EXTRACT(NAME,1,31)
+4 SET TEMP=TEMP_" "_$$LJ^XLFSTR(TNAME,31," ")
+5 SET TEMP=TEMP_" "_$$RJ^XLFSTR(TOT,8," ")
+6 IF ETYP'="FC"
Begin DoDot:1
+7 SET TEMP=TEMP_$$RJ^XLFSTR(APPL,8," ")
+8 SET TEMP=TEMP_$$RJ^XLFSTR(NAPPL,7," ")
+9 SET TEMP=TEMP_$$RJ^XLFSTR(DUE,7," ")
+10 SET TEMP=TEMP_$$RJ^XLFSTR(NDUE,7," ")
End DoDot:1
+11 QUIT TEMP
+12 ;
HDR ; Header code
+1 SET VALMHDR(1)="Extract Summary Name: "_$PIECE($GET(^PXRMXT(810.3,IEN,0)),U)
+2 SET VALMHDR(2)=" Extract Period: "_$$FMTE^XLFDT($PIECE($GET(^PXRMXT(810.3,IEN,0)),U,2),"5Z")_" - "_$$FMTE^XLFDT($PIECE($GET(^PXRMXT(810.3,IEN,0)),U,3),"5Z")
+3 SET VALMHDR(2)=VALMHDR(2)_" Created: "_$$FMTE^XLFDT($PIECE($GET(^PXRMXT(810.3,IEN,0)),U,6),"5Z")
+4 SET VALMSG="+ Next Screen - Prev Screen ?? More Actions"
+5 QUIT
+6 ;
HLP ;Help code
+1 NEW ORU,ORUPRMT,XQORM
+2 SET SUB="PXRMETTH"
+3 DO EN^VALM("PXRM EXTRACT HELP")
+4 QUIT
+5 ;
INIT ;Init
+1 SET VALMCNT=0
+2 QUIT
+3 ;
PBLD(IEN,IND,SUB) ;
+1 NEW ARRAY,NAME,LEN,PCNT,DFN,CNT,USTR
+2 SET VALMCNT=VALMCNT+1
SET CNT=0
+3 SET PCNT=0
FOR
SET PCNT=$ORDER(^PXRMXT(810.3,IEN,3,IND,1,SUB,1,PCNT))
if PCNT'>0
QUIT
Begin DoDot:1
+4 SET DFN=$PIECE($GET(^PXRMXT(810.3,IEN,3,IND,1,SUB,1,PCNT,0)),U)
if DFN'>0
QUIT
+5 SET NAME=$PIECE($GET(^DPT(DFN,0)),U)
+6 SET CNT=CNT+1
SET ARRAY(NAME)=""
End DoDot:1
+7 SET ^TMP("PXRMETT",$JOB,VALMCNT,0)=" "_$$RJ^XLFSTR("Unique Applicable Patients ("_CNT_")",36," ")
+8 SET USTR=$PIECE($GET(^TMP("PXRMETT",$JOB,VALMCNT,0)),"U")
SET LEN=$LENGTH(USTR)
+9 SET ^TMP("PXRMETT",$JOB,"IDX",VALMCNT,PLCNT)=""
+10 SET NAME=""
FOR
SET NAME=$ORDER(ARRAY(NAME))
if NAME=""
QUIT
Begin DoDot:1
+11 SET VALMCNT=VALMCNT+1
+12 SET ^TMP("PXRMETT",$JOB,VALMCNT,0)=USTR_$$LJ^XLFSTR(NAME,36," ")
+13 SET ^TMP("PXRMETT",$JOB,"IDX",VALMCNT,PLCNT)=""
End DoDot:1
+14 SET VALMCNT=VALMCNT+1
+15 SET ^TMP("PXRMETT",$JOB,VALMCNT,0)=" "
+16 SET ^TMP("PXRMETT",$JOB,"IDX",VALMCNT,PLCNT)=""
+17 QUIT
+18 ;
PEXIT ;Protocol exit code
+1 SET VALMSG="+ Next Screen - Prev Screen ?? More Actions"
+2 DO XQORM
+3 QUIT
+4 ;
PLIST(IEN) ;Patient list display
+1 NEW IND,PLIEN,VALMY
+2 DO EN^VALM2(XQORNOD(0))
+3 ;If there is no list quit.
+4 IF '$DATA(VALMY)
QUIT
+5 ;PXRMDONE is newed in PXRMLPM
+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 PLIEN=^TMP("PXRMETT",$JOB,"SEL",IND)
+11 DO START^PXRMLPP(PLIEN)
End DoDot:1
+12 SET VALMBCK="R"
+13 QUIT
+14 ;
PLIST1 ;Toggle list with/without finding totals
+1 SET TOGGLE1=(TOGGLE1+1)#2
+2 ;Rebuild Workfile
+3 DO BLDLIST(IEN,TOGGLE,TOGGLE1)
+4 ;Refresh
+5 SET VALMBCK="R"
SET VALMBG=1
+6 QUIT
+7 ;
XQORM SET XQORM("#")=$ORDER(^ORD(101,"B","PXRM EXTRACT SUMMARY SELECT ENTRY",0))_U_"1:"_VALMCNT
+1 SET XQORM("A")="Select Item: "
+2 QUIT
+3 ;
XSEL ;PXRM EXTRACT TOTALS SELECT ENTRY validation
+1 NEW SEL,PLIEN
+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@("SEL",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 ;Get the list ien.
+13 SET PLIEN=^TMP("PXRMETT",$JOB,"SEL",SEL)
+14 DO START^PXRMLPP(PLIEN)
+15 SET VALMBCK="R"
+16 QUIT
+17 ;
