PSOPMP0 ;BIRM/MFR - Patient Medication Profile - Listmanager ;10/28/06
;;7.0;OUTPATIENT PHARMACY;**260,281,303,289**;DEC 1997;Build 107
;Reference to EN1^GMRADPT supported by IA #10099
;Reference to EN6^GMRVUTL supported by IA #1120
;Reference to ^PS(55 supported by DBIA 2228
;
EN ;Menu option entry point
N PSOEXPDC,PSOEXDCE,PSOSRTBY,PSORDER,PSOSIGDP,PSOSTSGP,PSOSTORD,PSORDCNT,PSOSTSEQ,PSORDSEQ,PSOCHNG
N GRPLN,DIC,Y,DFN,GRPLN,HIGHLN,LASTLINE,VALMCNT
;
;Division selection
I '$G(PSOSITE) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,"Pharmacy Division Must be Selected!",! G EXIT
;
;Patient selection
W !! S DIC=2,DIC(0)="QEAM" D ^DIC G EXIT:Y<0 S DFN=+Y
S PSODFN=DFN D CHKADDR^PSOBAI(DFN,1,1) ;bad address flag/update
D LST(PSOSITE,DFN)
Q
;
LST(SITE,PSODFN) ;ListManager entry point
; Loading Division/User preferences
D LOAD^PSOPMPPF(SITE,DUZ)
W !,"Please wait..."
D EN^VALM("PSO PMP MAIN")
D FULL^VALM1
G EXIT
;
HDR ;Header
N LINE,POS,LINE1,LINE2,LINE3,LINE4,WT,WTDT,HT,HTDT,VADM,DFN,PNAME,DOB,SEX,X,GMRAL,ADVREA
K VADM S DFN=PSODFN D DEM^VADPT
S PNAME=VADM(1)
S DOB=$S(+VADM(3):$P(VADM(3),"^",2)_" ("_$G(VADM(4))_")",1:"UNKNOWN")
S SEX=$P(VADM(5),"^",2)
S (WT,X)="",GMRVSTR="WT" D EN6^GMRVUTL I X'="" S WT=$J($P(X,"^",8)/2.2,6,2),WTDT=$$DAT^PSOPMP1($P(X,"^")\1,"/",1)
S (HT,X)="",GMRVSTR="HT" D EN6^GMRVUTL I X'="" S HT=$J($P(X,"^",8)*2.54,6,2),HTDT=$$DAT^PSOPMP1($P(X,"^")\1,"/",1)
S LINE1=PNAME
S LINE1=$$ALLERGY^PSOPMP1(LINE1,DFN)
S LINE2=" PID: "_$P(VADM(2),"^",2),$E(LINE2,50)="HEIGHT(cm): "_$S(HT'="":HT_" ("_HTDT_")",1:"NOT AVAILABLE")
S LINE3=" DOB: "_DOB,$E(LINE3,50)="WEIGHT(kg): "_$S(WT'="":WT_" ("_WTDT_")",1:"NOT AVAILABLE")
S LINE4=" SEX: "_SEX,$E(LINE4,43)="EXP/CANCEL CUTOFF: "_PSOEXDCE_" DAYS"
;
K VALMHDR S VALMHDR(1)=LINE1,VALMHDR(2)=LINE2,VALMHDR(3)=LINE3,VALMHDR(4)=LINE4
D SETHDR^PSOPMP1()
Q
;
INIT ;Populates the Body section for ListMan
K ^TMP("PSOPMP0",$J),^TMP("PSOPMPSR",$J)
D SETSORT(PSOSRTBY),SETLINE
S VALMSG="Select the entry # to view or ?? for more actions"
Q
;
SETLINE ;Sets the line to be displayed in ListMan
N TYPE,STS,SUB,SEQ,LINE,Z,TOTAL,I,X,X1,ORDCNT,LBL,LN,IENSUB,GROUP,GRP,QTYL
I '$D(^TMP("PSOPMPSR",$J)) D Q
. F I=1:1:6 S ^TMP("PSOPMP0",$J,I,0)=""
. S ^TMP("PSOPMP0",$J,7,0)=" No prescriptions found for this patient."
. S VALMCNT=1
;
;Resetting list to NORMAL video attributes
F I=1:1:$G(LASTLINE) D RESTORE^VALM10(I)
K GRPLN,HIGHLN
;Building the list (line by line)
S (GROUP,STS,SUB)="",LINE=0 K ^TMP("PSOPMP0",$J)
F S GROUP=$O(^TMP("PSOPMPSR",$J,GROUP)) Q:GROUP="" D
. S GRP=$P(GROUP,"^")
. I GRP'["R"!('PSOSTSGP&($O(^TMP("PSOPMPSR",$J,GROUP),-1)'="")) D
. . D GROUP^PSOPMP1($P(GROUP,"^",2),+$G(^TMP("PSOPMPSR",$J,GROUP)),.LINE)
. F S STS=$O(^TMP("PSOPMPSR",$J,GROUP,STS)) Q:STS="" D
. . I STS'="<NULL>" D
. . . D GROUP^PSOPMP1($P(STS,"^",2),+$G(^TMP("PSOPMPSR",$J,GROUP,STS)),.LINE)
. . F S SUB=$O(^TMP("PSOPMPSR",$J,GROUP,STS,SUB),$S(PSORDER="A":1,1:-1)) Q:SUB="" D
. . . S Z=$G(^TMP("PSOPMPSR",$J,GROUP,STS,SUB))
. . . S X1="",SEQ=$G(SEQ)+1,X1=$J(SEQ,3)
. . . S QTYL=$L($P(Z,"^",4)) S:QTYL<5 QTYL=5
. . . I GRP["R"!(GRP["T") S $E(X1,5)=$P(Z,"^",2),$E(X1,19)=$E($P(Z,"^",3),1,(32-QTYL))
. . . I GRP["P"!(GRP["N") S $E(X1,5)=$P(Z,"^",3)
. . . I GRP["N" S $E(X1,49)="Date Documented:"
. . . I GRP'["N" S $E(X1,52-QTYL)=$J($P(Z,"^",4),QTYL),$E(X1,53)=$P(Z,"^",5),$E(X1,57)=$P(Z,"^",6)
. . . S $E(X1,66)=$P(Z,"^",7)
. . . S $E(X1,74)=$J($P(Z,"^",8),3),$E(X1,78)=$J($P(Z,"^",9),3)
. . . S LINE=LINE+1,^TMP("PSOPMP0",$J,LINE,0)=X1,HIGHLN(LINE)=""
. . . S IENSUB=$S(GRP["R"!(GRP["T"):"RX",GRP["P":"PEN",1:"NVA")
. . . S ^TMP("PSOPMP0",$J,SEQ,IENSUB)=$P(Z,"^")
. . . I IENSUB="PEN"&($P($G(^PS(52.41,+$P(Z,"^"),0)),"^",23)=1) S ^TMP("PSOPMP0",$J,LINE,"RV")=1
. . . I $G(PSOSIGDP) D SETSIG^PSOPMP1($S(GRP["R"!(GRP["T"):"R",GRP["P":"P",1:"N"),+Z,.LINE,PSODFN)
;
;Saving NORMAL video attributes to be reset later
I LINE>$G(LASTLINE) D
. F I=($G(LASTLINE)+1):1:LINE D SAVE^VALM10(I)
. S LASTLINE=LINE
D VIDEO^PSOPMP1()
S VALMCNT=+$G(LINE) D RV^PSOPMP1
Q
;
SETSORT(FIELD) ;Sets the data sorted by the FIELD specified
N SEQ,RX,RXNUM,DRUG,DRNAME,QTY,STATUS,STS,ISSDT,DOCDAT,LSTFD,REFREM,DAYSUP,SIG,Z,ORD,GRPCNT,GROUP,RFRX,OI,PSOBADR
K ^TMP("PSOPMPSR",$J)
;Loading prescription (file #55)
S SEQ=0
F S SEQ=$O(^PS(55,PSODFN,"P",SEQ)) Q:'SEQ D
. S RX=+$G(^PS(55,PSODFN,"P",SEQ,0)) I 'RX!($G(^PSRX(RX,0))="") Q
. I $$FILTER^PSOPMP1(RX) Q
. S RXNUM=$$GET1^DIQ(52,RX,.01)
. S DRUG=$$GET1^DIQ(52,RX,6,"I")
. S DRNAME=$$GET1^DIQ(50,DRUG,.01)
. S QTY=$$GET1^DIQ(52,RX,7)
. S STATUS=$$STSINFO^PSOPMP1(RX)
. S ISSDT=$$ISSDT^PSOPMP1(RX,"R")
. S LSTFD=$$LSTFD^PSOPMP1(RX)
. S REFREM=$$REFREM^PSOPMP1(RX)
. S DAYSUP=$$GET1^DIQ(52,RX,8)
. S PSOBADR=$O(^PSRX(RX,"L",9999),-1)
. I PSOBADR'="" S PSOBADR=$G(^PSRX(RX,"L",PSOBADR,0)) I PSOBADR["(BAD ADDRESS)" S PSOBADR="B"
. I PSOBADR'="B" S PSOBADR=""
. S Z="",$P(Z,"^")=RX,$P(Z,"^",2)=RXNUM_$$COPAY^PSOPMP1(RX)_$$ECME^PSOBPSUT(RX),$P(Z,"^",3)=$E(DRNAME,1,30)
. S $P(Z,"^",4)=QTY,$P(Z,"^",5)=$P(STATUS,"^",3)_$$CMOP^PSOPMP1(DRUG,RX)_PSOBADR,$P(Z,"^",6)=$P(ISSDT,"^",2)
. S $P(Z,"^",7)=$P(LSTFD,"^",2),$P(Z,"^",8)=REFREM,$P(Z,"^",9)=DAYSUP
. S SORT=$S(FIELD="RX":RXNUM_" ",FIELD="DR":DRNAME_RXNUM,FIELD="ID":+ISSDT_RXNUM_" ",FIELD="LF":+LSTFD_RXNUM_" ")
. S STS="<NULL>" I $G(PSOSTSGP) S STS=$P(STATUS,"^")_"^"_$P(STATUS,"^",2)
. S GROUP=$P(PSORDSEQ("R"),"^")_"R^"_$P(PSORDSEQ("R"),"^",2)
. I $$FIND^PSOREJUT(RX,,,"79,88") S GROUP=$P(PSORDSEQ("T"),"^")_"T^"_$P(PSORDSEQ("T"),"^",2),STS="<NULL>"
. S ^TMP("PSOPMPSR",$J,GROUP,STS,SORT)=Z
. S GRPCNT(GROUP)=$G(GRPCNT(GROUP))+1,GRPCNT(GROUP,STS)=$G(GRPCNT(GROUP,STS))+1
;
S GROUP=""
F S GROUP=$O(GRPCNT(GROUP)) Q:GROUP="" D
. S ^TMP("PSOPMPSR",$J,GROUP)=$G(GRPCNT(GROUP))
. S STS="" F S STS=$O(GRPCNT(GROUP,STS)) Q:STS="" D
. . S ^TMP("PSOPMPSR",$J,GROUP,STS)=GRPCNT(GROUP,STS)
;
;Loading pending orders (file #52.41)
S ORD=0,GROUP=$P(PSORDSEQ("P"),"^")_"P^"_$P(PSORDSEQ("P"),"^",2)
F S ORD=$O(^PS(52.41,"P",PSODFN,ORD)) Q:'ORD D
. S TYPE=$$GET1^DIQ(52.41,ORD,2,"I")
. I TYPE="DC"!(TYPE="DE")!(TYPE="HD") Q
. S DRNAME="",DRUG=+$$GET1^DIQ(52.41,ORD,11,"I") I DRUG S DRNAME=$$GET1^DIQ(50,DRUG,.01)
. I DRNAME="" D Q:DRNAME=""
. . S OI=$$GET1^DIQ(52.41,ORD,8,"I") I 'OI Q
. . S DRNAME=$$GET1^DIQ(50.7,OI,.01)_" "_$$GET1^DIQ(50.7,OI,.02)
. S QTY=$$GET1^DIQ(52.41,ORD,12)
. S STATUS=$$GET1^DIQ(52.41,ORD,2,"I")
. S ISSDT=$$ISSDT^PSOPMP1(ORD,"P")
. S REFREM=$$GET1^DIQ(52.41,ORD,13)
. S DAYSUP=$$GET1^DIQ(52.41,ORD,101)
. S RFRX="" I STATUS="RF" S RFRX=$$GET1^DIQ(52.41,ORD,21,"I") I RFRX S RFRX=$$GET1^DIQ(52,RFRX,.01)
. S Z="",$P(Z,"^")=ORD,$P(Z,"^",3)=$E(DRNAME,1,45),$P(Z,"^",4)=QTY,$P(Z,"^",5)=$E(STATUS,1,2)_$$CMOP^PSOPMP1(DRUG)
. S $P(Z,"^",6)=$S(RFRX'="":"Rx#: "_RFRX,1:$P(ISSDT,"^",2)),$P(Z,"^",8)=REFREM,$P(Z,"^",9)=DAYSUP
. S SORT=$S(FIELD="RX":DRNAME_ORD,FIELD="DR":DRNAME_ORD,FIELD="ID":+ISSDT_ORD,FIELD="LF":+ISSDT_ORD)
. S ^TMP("PSOPMPSR",$J,GROUP,"<NULL>",SORT)=Z
. S GRPCNT(GROUP)=$G(GRPCNT(GROUP))+1
S:$G(GRPCNT(GROUP)) ^TMP("PSOPMPSR",$J,GROUP)=$G(GRPCNT(GROUP))
;
;Loading Non-VA Med orders (file #55, sub-file #55.05)
S ORD=0,GROUP=$P(PSORDSEQ("N"),"^")_"N^"_$P(PSORDSEQ("N"),"^",2)
F S ORD=$O(^PS(55,PSODFN,"NVA",ORD)) Q:'ORD D
. I $$GET1^DIQ(55.05,ORD_","_PSODFN,5,"I") Q
. S DRNAME=$$GET1^DIQ(55.05,ORD_","_PSODFN,1)
. I DRNAME="" D Q:DRNAME=""
. . S OI=$$GET1^DIQ(55.05,ORD_","_PSODFN,.01,"I") I 'OI Q
. . S DRNAME=$$GET1^DIQ(50.7,OI,.01)_" "_$$GET1^DIQ(50.7,OI,.02)
. S DOCDAT=$P($$GET1^DIQ(55.05,ORD_","_PSODFN_",",11,"I"),".")
. S Z="",$P(Z,"^")=ORD,$P(Z,"^",3)=$E(DRNAME,1,38),$P(Z,"^",7)=$$DAT^PSOPMP1(DOCDAT,"-")
. S SORT=$S(FIELD="RX":DRNAME_ORD,FIELD="DR":DRNAME_ORD,FIELD="ID":DOCDAT_ORD,FIELD="LF":DOCDAT_ORD)
. S ^TMP("PSOPMPSR",$J,GROUP,"<NULL>",SORT)=Z
. S GRPCNT(GROUP)=$G(GRPCNT(GROUP))+1
;
S:$G(GRPCNT(GROUP)) ^TMP("PSOPMPSR",$J,GROUP)=$G(GRPCNT(GROUP))
Q
;
RX ;Sort by Rx
D SORT("RX")
Q
DR ;Sort by Drug
D SORT("DR")
Q
ID ;Sort by Issue Date
D SORT("ID")
Q
LF ;Sort by Last Fill Date
D SORT("LF")
Q
;
SORT(FIELD) ;Sort entries by FIELD
I PSOSRTBY=FIELD S PSORDER=$S(PSORDER="A":"D",1:"A")
E S PSOSRTBY=FIELD,PSORDER="A"
D REF
Q
;
REF ;Screen Refresh
W ?52,"Please wait..." D INIT,HDR S VALMBCK="R"
Q
GS ;Group by Status
W ?52,"Please wait..." S PSOSTSGP=$S($G(PSOSTSGP):0,1:1) D INIT,HDR S VALMBCK="R"
Q
SIG ;Display SIG
W ?52,"Please wait..." S PSOSIGDP=$S($G(PSOSIGDP):0,1:1) D INIT,HDR S VALMBCK="R"
I 'PSOSIGDP S VALMBG=VALMBG\2
I PSOSIGDP S VALMBG=VALMBG*2-1
S:VALMBG>(VALMCNT-10) VALMBG=VALMCNT-10 S:VALMBG<1 VALMBG=1
Q
PI ;Patient Information
D EN^PSOLMPI S VALMBCK="R"
Q
CV ;Change View
D LST^PSOPMPPF(SITE,DUZ) W !?52,"Please wait..." D INIT,HDR
S VALMBG=1,VALMBCK="R"
Q
;
SEL ;Process selection of one entry
N PSOSEL,TYPE,XQORM,ORD,TITLE
S PSOSEL=+$P($P(Y(1),"^",4),"=",2) I 'PSOSEL S VALMSG="Invalid selection!",VALMBCK="R" Q
S TYPE=$O(^TMP("PSOPMP0",$J,PSOSEL,0)) I TYPE="" S VALMSG="Invalid selection!",VALMBCK="R" Q
S ORD=$G(^TMP("PSOPMP0",$J,PSOSEL,TYPE))
I 'ORD S VALMSG="Invalid selection!",VALMBCK="R" Q
S TITLE=VALM("TITLE")
;
;Regular prescription
I TYPE="RX" D S VALMBCK="R" D REF
. N PSOVDA,PSOSAVE,DA,PS
. S (PSOVDA,DA)=ORD,PS="REJECTMP"
. N LINE,TITLE,PSODFN D DP^PSORXVW
;
;Pending Order
I TYPE="PEN" D S VALMBCK="R" D REF
. N PSOACTOV,OR0
. S OR0=^PS(52.41,ORD,0),PSOACTOV=""
. N LINE,TITLE D PENHDR^PSOPMP1(PSODFN),DSPL^PSOORFI1
;
;Pending Order
I TYPE="NVA" D
. N LINE,TITLE D EN^PSONVAVW(PSODFN,ORD)
;
S VALMBCK="R",VALM("TITLE")=TITLE
Q
;
EXIT ;
K ^TMP("PSOPMP0",$J),^TMP("PSOPMPSR",$J)
Q
;
HELP Q
PSOPMP0 ;BIRM/MFR - Patient Medication Profile - Listmanager ;10/28/06
+1 ;;7.0;OUTPATIENT PHARMACY;**260,281,303,289**;DEC 1997;Build 107
+2 ;Reference to EN1^GMRADPT supported by IA #10099
+3 ;Reference to EN6^GMRVUTL supported by IA #1120
+4 ;Reference to ^PS(55 supported by DBIA 2228
+5 ;
EN ;Menu option entry point
+1 NEW PSOEXPDC,PSOEXDCE,PSOSRTBY,PSORDER,PSOSIGDP,PSOSTSGP,PSOSTORD,PSORDCNT,PSOSTSEQ,PSORDSEQ,PSOCHNG
+2 NEW GRPLN,DIC,Y,DFN,GRPLN,HIGHLN,LASTLINE,VALMCNT
+3 ;
+4 ;Division selection
+5 IF '$GET(PSOSITE)
DO ^PSOLSET
IF '$DATA(PSOPAR)
WRITE $CHAR(7),!!,"Pharmacy Division Must be Selected!",!
GOTO EXIT
+6 ;
+7 ;Patient selection
+8 WRITE !!
SET DIC=2
SET DIC(0)="QEAM"
DO ^DIC
IF Y<0
GOTO EXIT
SET DFN=+Y
+9 ;bad address flag/update
SET PSODFN=DFN
DO CHKADDR^PSOBAI(DFN,1,1)
+10 DO LST(PSOSITE,DFN)
+11 QUIT
+12 ;
LST(SITE,PSODFN) ;ListManager entry point
+1 ; Loading Division/User preferences
+2 DO LOAD^PSOPMPPF(SITE,DUZ)
+3 WRITE !,"Please wait..."
+4 DO EN^VALM("PSO PMP MAIN")
+5 DO FULL^VALM1
+6 GOTO EXIT
+7 ;
HDR ;Header
+1 NEW LINE,POS,LINE1,LINE2,LINE3,LINE4,WT,WTDT,HT,HTDT,VADM,DFN,PNAME,DOB,SEX,X,GMRAL,ADVREA
+2 KILL VADM
SET DFN=PSODFN
DO DEM^VADPT
+3 SET PNAME=VADM(1)
+4 SET DOB=$SELECT(+VADM(3):$PIECE(VADM(3),"^",2)_" ("_$GET(VADM(4))_")",1:"UNKNOWN")
+5 SET SEX=$PIECE(VADM(5),"^",2)
+6 SET (WT,X)=""
SET GMRVSTR="WT"
DO EN6^GMRVUTL
IF X'=""
SET WT=$JUSTIFY($PIECE(X,"^",8)/2.2,6,2)
SET WTDT=$$DAT^PSOPMP1($PIECE(X,"^")\1,"/",1)
+7 SET (HT,X)=""
SET GMRVSTR="HT"
DO EN6^GMRVUTL
IF X'=""
SET HT=$JUSTIFY($PIECE(X,"^",8)*2.54,6,2)
SET HTDT=$$DAT^PSOPMP1($PIECE(X,"^")\1,"/",1)
+8 SET LINE1=PNAME
+9 SET LINE1=$$ALLERGY^PSOPMP1(LINE1,DFN)
+10 SET LINE2=" PID: "_$PIECE(VADM(2),"^",2)
SET $EXTRACT(LINE2,50)="HEIGHT(cm): "_$SELECT(HT'="":HT_" ("_HTDT_")",1:"NOT AVAILABLE")
+11 SET LINE3=" DOB: "_DOB
SET $EXTRACT(LINE3,50)="WEIGHT(kg): "_$SELECT(WT'="":WT_" ("_WTDT_")",1:"NOT AVAILABLE")
+12 SET LINE4=" SEX: "_SEX
SET $EXTRACT(LINE4,43)="EXP/CANCEL CUTOFF: "_PSOEXDCE_" DAYS"
+13 ;
+14 KILL VALMHDR
SET VALMHDR(1)=LINE1
SET VALMHDR(2)=LINE2
SET VALMHDR(3)=LINE3
SET VALMHDR(4)=LINE4
+15 DO SETHDR^PSOPMP1()
+16 QUIT
+17 ;
INIT ;Populates the Body section for ListMan
+1 KILL ^TMP("PSOPMP0",$JOB),^TMP("PSOPMPSR",$JOB)
+2 DO SETSORT(PSOSRTBY)
DO SETLINE
+3 SET VALMSG="Select the entry # to view or ?? for more actions"
+4 QUIT
+5 ;
SETLINE ;Sets the line to be displayed in ListMan
+1 NEW TYPE,STS,SUB,SEQ,LINE,Z,TOTAL,I,X,X1,ORDCNT,LBL,LN,IENSUB,GROUP,GRP,QTYL
+2 IF '$DATA(^TMP("PSOPMPSR",$JOB))
Begin DoDot:1
+3 FOR I=1:1:6
SET ^TMP("PSOPMP0",$JOB,I,0)=""
+4 SET ^TMP("PSOPMP0",$JOB,7,0)=" No prescriptions found for this patient."
+5 SET VALMCNT=1
End DoDot:1
QUIT
+6 ;
+7 ;Resetting list to NORMAL video attributes
+8 FOR I=1:1:$GET(LASTLINE)
DO RESTORE^VALM10(I)
+9 KILL GRPLN,HIGHLN
+10 ;Building the list (line by line)
+11 SET (GROUP,STS,SUB)=""
SET LINE=0
KILL ^TMP("PSOPMP0",$JOB)
+12 FOR
SET GROUP=$ORDER(^TMP("PSOPMPSR",$JOB,GROUP))
IF GROUP=""
QUIT
Begin DoDot:1
+13 SET GRP=$PIECE(GROUP,"^")
+14 IF GRP'["R"!('PSOSTSGP&($ORDER(^TMP("PSOPMPSR",$JOB,GROUP),-1)'=""))
Begin DoDot:2
+15 DO GROUP^PSOPMP1($PIECE(GROUP,"^",2),+$GET(^TMP("PSOPMPSR",$JOB,GROUP)),.LINE)
End DoDot:2
+16 FOR
SET STS=$ORDER(^TMP("PSOPMPSR",$JOB,GROUP,STS))
IF STS=""
QUIT
Begin DoDot:2
+17 IF STS'="<NULL>"
Begin DoDot:3
+18 DO GROUP^PSOPMP1($PIECE(STS,"^",2),+$GET(^TMP("PSOPMPSR",$JOB,GROUP,STS)),.LINE)
End DoDot:3
+19 FOR
SET SUB=$ORDER(^TMP("PSOPMPSR",$JOB,GROUP,STS,SUB),$SELECT(PSORDER="A":1,1:-1))
IF SUB=""
QUIT
Begin DoDot:3
+20 SET Z=$GET(^TMP("PSOPMPSR",$JOB,GROUP,STS,SUB))
+21 SET X1=""
SET SEQ=$GET(SEQ)+1
SET X1=$JUSTIFY(SEQ,3)
+22 SET QTYL=$LENGTH($PIECE(Z,"^",4))
IF QTYL<5
SET QTYL=5
+23 IF GRP["R"!(GRP["T")
SET $EXTRACT(X1,5)=$PIECE(Z,"^",2)
SET $EXTRACT(X1,19)=$EXTRACT($PIECE(Z,"^",3),1,(32-QTYL))
+24 IF GRP["P"!(GRP["N")
SET $EXTRACT(X1,5)=$PIECE(Z,"^",3)
+25 IF GRP["N"
SET $EXTRACT(X1,49)="Date Documented:"
+26 IF GRP'["N"
SET $EXTRACT(X1,52-QTYL)=$JUSTIFY($PIECE(Z,"^",4),QTYL)
SET $EXTRACT(X1,53)=$PIECE(Z,"^",5)
SET $EXTRACT(X1,57)=$PIECE(Z,"^",6)
+27 SET $EXTRACT(X1,66)=$PIECE(Z,"^",7)
+28 SET $EXTRACT(X1,74)=$JUSTIFY($PIECE(Z,"^",8),3)
SET $EXTRACT(X1,78)=$JUSTIFY($PIECE(Z,"^",9),3)
+29 SET LINE=LINE+1
SET ^TMP("PSOPMP0",$JOB,LINE,0)=X1
SET HIGHLN(LINE)=""
+30 SET IENSUB=$SELECT(GRP["R"!(GRP["T"):"RX",GRP["P":"PEN",1:"NVA")
+31 SET ^TMP("PSOPMP0",$JOB,SEQ,IENSUB)=$PIECE(Z,"^")
+32 IF IENSUB="PEN"&($PIECE($GET(^PS(52.41,+$PIECE(Z,"^"),0)),"^",23)=1)
SET ^TMP("PSOPMP0",$JOB,LINE,"RV")=1
+33 IF $GET(PSOSIGDP)
DO SETSIG^PSOPMP1($SELECT(GRP["R"!(GRP["T"):"R",GRP["P":"P",1:"N"),+Z,.LINE,PSODFN)
End DoDot:3
End DoDot:2
End DoDot:1
+34 ;
+35 ;Saving NORMAL video attributes to be reset later
+36 IF LINE>$GET(LASTLINE)
Begin DoDot:1
+37 FOR I=($GET(LASTLINE)+1):1:LINE
DO SAVE^VALM10(I)
+38 SET LASTLINE=LINE
End DoDot:1
+39 DO VIDEO^PSOPMP1()
+40 SET VALMCNT=+$GET(LINE)
DO RV^PSOPMP1
+41 QUIT
+42 ;
SETSORT(FIELD) ;Sets the data sorted by the FIELD specified
+1 NEW SEQ,RX,RXNUM,DRUG,DRNAME,QTY,STATUS,STS,ISSDT,DOCDAT,LSTFD,REFREM,DAYSUP,SIG,Z,ORD,GRPCNT,GROUP,RFRX,OI,PSOBADR
+2 KILL ^TMP("PSOPMPSR",$JOB)
+3 ;Loading prescription (file #55)
+4 SET SEQ=0
+5 FOR
SET SEQ=$ORDER(^PS(55,PSODFN,"P",SEQ))
IF 'SEQ
QUIT
Begin DoDot:1
+6 SET RX=+$GET(^PS(55,PSODFN,"P",SEQ,0))
IF 'RX!($GET(^PSRX(RX,0))="")
QUIT
+7 IF $$FILTER^PSOPMP1(RX)
QUIT
+8 SET RXNUM=$$GET1^DIQ(52,RX,.01)
+9 SET DRUG=$$GET1^DIQ(52,RX,6,"I")
+10 SET DRNAME=$$GET1^DIQ(50,DRUG,.01)
+11 SET QTY=$$GET1^DIQ(52,RX,7)
+12 SET STATUS=$$STSINFO^PSOPMP1(RX)
+13 SET ISSDT=$$ISSDT^PSOPMP1(RX,"R")
+14 SET LSTFD=$$LSTFD^PSOPMP1(RX)
+15 SET REFREM=$$REFREM^PSOPMP1(RX)
+16 SET DAYSUP=$$GET1^DIQ(52,RX,8)
+17 SET PSOBADR=$ORDER(^PSRX(RX,"L",9999),-1)
+18 IF PSOBADR'=""
SET PSOBADR=$GET(^PSRX(RX,"L",PSOBADR,0))
IF PSOBADR["(BAD ADDRESS)"
SET PSOBADR="B"
+19 IF PSOBADR'="B"
SET PSOBADR=""
+20 SET Z=""
SET $PIECE(Z,"^")=RX
SET $PIECE(Z,"^",2)=RXNUM_$$COPAY^PSOPMP1(RX)_$$ECME^PSOBPSUT(RX)
SET $PIECE(Z,"^",3)=$EXTRACT(DRNAME,1,30)
+21 SET $PIECE(Z,"^",4)=QTY
SET $PIECE(Z,"^",5)=$PIECE(STATUS,"^",3)_$$CMOP^PSOPMP1(DRUG,RX)_PSOBADR
SET $PIECE(Z,"^",6)=$PIECE(ISSDT,"^",2)
+22 SET $PIECE(Z,"^",7)=$PIECE(LSTFD,"^",2)
SET $PIECE(Z,"^",8)=REFREM
SET $PIECE(Z,"^",9)=DAYSUP
+23 SET SORT=$SELECT(FIELD="RX":RXNUM_" ",FIELD="DR":DRNAME_RXNUM,FIELD="ID":+ISSDT_RXNUM_" ",FIELD="LF":+LSTFD_RXNUM_" ")
+24 SET STS="<NULL>"
IF $GET(PSOSTSGP)
SET STS=$PIECE(STATUS,"^")_"^"_$PIECE(STATUS,"^",2)
+25 SET GROUP=$PIECE(PSORDSEQ("R"),"^")_"R^"_$PIECE(PSORDSEQ("R"),"^",2)
+26 IF $$FIND^PSOREJUT(RX,,,"79,88")
SET GROUP=$PIECE(PSORDSEQ("T"),"^")_"T^"_$PIECE(PSORDSEQ("T"),"^",2)
SET STS="<NULL>"
+27 SET ^TMP("PSOPMPSR",$JOB,GROUP,STS,SORT)=Z
+28 SET GRPCNT(GROUP)=$GET(GRPCNT(GROUP))+1
SET GRPCNT(GROUP,STS)=$GET(GRPCNT(GROUP,STS))+1
End DoDot:1
+29 ;
+30 SET GROUP=""
+31 FOR
SET GROUP=$ORDER(GRPCNT(GROUP))
IF GROUP=""
QUIT
Begin DoDot:1
+32 SET ^TMP("PSOPMPSR",$JOB,GROUP)=$GET(GRPCNT(GROUP))
+33 SET STS=""
FOR
SET STS=$ORDER(GRPCNT(GROUP,STS))
IF STS=""
QUIT
Begin DoDot:2
+34 SET ^TMP("PSOPMPSR",$JOB,GROUP,STS)=GRPCNT(GROUP,STS)
End DoDot:2
End DoDot:1
+35 ;
+36 ;Loading pending orders (file #52.41)
+37 SET ORD=0
SET GROUP=$PIECE(PSORDSEQ("P"),"^")_"P^"_$PIECE(PSORDSEQ("P"),"^",2)
+38 FOR
SET ORD=$ORDER(^PS(52.41,"P",PSODFN,ORD))
IF 'ORD
QUIT
Begin DoDot:1
+39 SET TYPE=$$GET1^DIQ(52.41,ORD,2,"I")
+40 IF TYPE="DC"!(TYPE="DE")!(TYPE="HD")
QUIT
+41 SET DRNAME=""
SET DRUG=+$$GET1^DIQ(52.41,ORD,11,"I")
IF DRUG
SET DRNAME=$$GET1^DIQ(50,DRUG,.01)
+42 IF DRNAME=""
Begin DoDot:2
+43 SET OI=$$GET1^DIQ(52.41,ORD,8,"I")
IF 'OI
QUIT
+44 SET DRNAME=$$GET1^DIQ(50.7,OI,.01)_" "_$$GET1^DIQ(50.7,OI,.02)
End DoDot:2
IF DRNAME=""
QUIT
+45 SET QTY=$$GET1^DIQ(52.41,ORD,12)
+46 SET STATUS=$$GET1^DIQ(52.41,ORD,2,"I")
+47 SET ISSDT=$$ISSDT^PSOPMP1(ORD,"P")
+48 SET REFREM=$$GET1^DIQ(52.41,ORD,13)
+49 SET DAYSUP=$$GET1^DIQ(52.41,ORD,101)
+50 SET RFRX=""
IF STATUS="RF"
SET RFRX=$$GET1^DIQ(52.41,ORD,21,"I")
IF RFRX
SET RFRX=$$GET1^DIQ(52,RFRX,.01)
+51 SET Z=""
SET $PIECE(Z,"^")=ORD
SET $PIECE(Z,"^",3)=$EXTRACT(DRNAME,1,45)
SET $PIECE(Z,"^",4)=QTY
SET $PIECE(Z,"^",5)=$EXTRACT(STATUS,1,2)_$$CMOP^PSOPMP1(DRUG)
+52 SET $PIECE(Z,"^",6)=$SELECT(RFRX'="":"Rx#: "_RFRX,1:$PIECE(ISSDT,"^",2))
SET $PIECE(Z,"^",8)=REFREM
SET $PIECE(Z,"^",9)=DAYSUP
+53 SET SORT=$SELECT(FIELD="RX":DRNAME_ORD,FIELD="DR":DRNAME_ORD,FIELD="ID":+ISSDT_ORD,FIELD="LF":+ISSDT_ORD)
+54 SET ^TMP("PSOPMPSR",$JOB,GROUP,"<NULL>",SORT)=Z
+55 SET GRPCNT(GROUP)=$GET(GRPCNT(GROUP))+1
End DoDot:1
+56 IF $GET(GRPCNT(GROUP))
SET ^TMP("PSOPMPSR",$JOB,GROUP)=$GET(GRPCNT(GROUP))
+57 ;
+58 ;Loading Non-VA Med orders (file #55, sub-file #55.05)
+59 SET ORD=0
SET GROUP=$PIECE(PSORDSEQ("N"),"^")_"N^"_$PIECE(PSORDSEQ("N"),"^",2)
+60 FOR
SET ORD=$ORDER(^PS(55,PSODFN,"NVA",ORD))
IF 'ORD
QUIT
Begin DoDot:1
+61 IF $$GET1^DIQ(55.05,ORD_","_PSODFN,5,"I")
QUIT
+62 SET DRNAME=$$GET1^DIQ(55.05,ORD_","_PSODFN,1)
+63 IF DRNAME=""
Begin DoDot:2
+64 SET OI=$$GET1^DIQ(55.05,ORD_","_PSODFN,.01,"I")
IF 'OI
QUIT
+65 SET DRNAME=$$GET1^DIQ(50.7,OI,.01)_" "_$$GET1^DIQ(50.7,OI,.02)
End DoDot:2
IF DRNAME=""
QUIT
+66 SET DOCDAT=$PIECE($$GET1^DIQ(55.05,ORD_","_PSODFN_",",11,"I"),".")
+67 SET Z=""
SET $PIECE(Z,"^")=ORD
SET $PIECE(Z,"^",3)=$EXTRACT(DRNAME,1,38)
SET $PIECE(Z,"^",7)=$$DAT^PSOPMP1(DOCDAT,"-")
+68 SET SORT=$SELECT(FIELD="RX":DRNAME_ORD,FIELD="DR":DRNAME_ORD,FIELD="ID":DOCDAT_ORD,FIELD="LF":DOCDAT_ORD)
+69 SET ^TMP("PSOPMPSR",$JOB,GROUP,"<NULL>",SORT)=Z
+70 SET GRPCNT(GROUP)=$GET(GRPCNT(GROUP))+1
End DoDot:1
+71 ;
+72 IF $GET(GRPCNT(GROUP))
SET ^TMP("PSOPMPSR",$JOB,GROUP)=$GET(GRPCNT(GROUP))
+73 QUIT
+74 ;
RX ;Sort by Rx
+1 DO SORT("RX")
+2 QUIT
DR ;Sort by Drug
+1 DO SORT("DR")
+2 QUIT
ID ;Sort by Issue Date
+1 DO SORT("ID")
+2 QUIT
LF ;Sort by Last Fill Date
+1 DO SORT("LF")
+2 QUIT
+3 ;
SORT(FIELD) ;Sort entries by FIELD
+1 IF PSOSRTBY=FIELD
SET PSORDER=$SELECT(PSORDER="A":"D",1:"A")
+2 IF '$TEST
SET PSOSRTBY=FIELD
SET PSORDER="A"
+3 DO REF
+4 QUIT
+5 ;
REF ;Screen Refresh
+1 WRITE ?52,"Please wait..."
DO INIT
DO HDR
SET VALMBCK="R"
+2 QUIT
GS ;Group by Status
+1 WRITE ?52,"Please wait..."
SET PSOSTSGP=$SELECT($GET(PSOSTSGP):0,1:1)
DO INIT
DO HDR
SET VALMBCK="R"
+2 QUIT
SIG ;Display SIG
+1 WRITE ?52,"Please wait..."
SET PSOSIGDP=$SELECT($GET(PSOSIGDP):0,1:1)
DO INIT
DO HDR
SET VALMBCK="R"
+2 IF 'PSOSIGDP
SET VALMBG=VALMBG\2
+3 IF PSOSIGDP
SET VALMBG=VALMBG*2-1
+4 IF VALMBG>(VALMCNT-10)
SET VALMBG=VALMCNT-10
IF VALMBG<1
SET VALMBG=1
+5 QUIT
PI ;Patient Information
+1 DO EN^PSOLMPI
SET VALMBCK="R"
+2 QUIT
CV ;Change View
+1 DO LST^PSOPMPPF(SITE,DUZ)
WRITE !?52,"Please wait..."
DO INIT
DO HDR
+2 SET VALMBG=1
SET VALMBCK="R"
+3 QUIT
+4 ;
SEL ;Process selection of one entry
+1 NEW PSOSEL,TYPE,XQORM,ORD,TITLE
+2 SET PSOSEL=+$PIECE($PIECE(Y(1),"^",4),"=",2)
IF 'PSOSEL
SET VALMSG="Invalid selection!"
SET VALMBCK="R"
QUIT
+3 SET TYPE=$ORDER(^TMP("PSOPMP0",$JOB,PSOSEL,0))
IF TYPE=""
SET VALMSG="Invalid selection!"
SET VALMBCK="R"
QUIT
+4 SET ORD=$GET(^TMP("PSOPMP0",$JOB,PSOSEL,TYPE))
+5 IF 'ORD
SET VALMSG="Invalid selection!"
SET VALMBCK="R"
QUIT
+6 SET TITLE=VALM("TITLE")
+7 ;
+8 ;Regular prescription
+9 IF TYPE="RX"
Begin DoDot:1
+10 NEW PSOVDA,PSOSAVE,DA,PS
+11 SET (PSOVDA,DA)=ORD
SET PS="REJECTMP"
+12 NEW LINE,TITLE,PSODFN
DO DP^PSORXVW
End DoDot:1
SET VALMBCK="R"
DO REF
+13 ;
+14 ;Pending Order
+15 IF TYPE="PEN"
Begin DoDot:1
+16 NEW PSOACTOV,OR0
+17 SET OR0=^PS(52.41,ORD,0)
SET PSOACTOV=""
+18 NEW LINE,TITLE
DO PENHDR^PSOPMP1(PSODFN)
DO DSPL^PSOORFI1
End DoDot:1
SET VALMBCK="R"
DO REF
+19 ;
+20 ;Pending Order
+21 IF TYPE="NVA"
Begin DoDot:1
+22 NEW LINE,TITLE
DO EN^PSONVAVW(PSODFN,ORD)
End DoDot:1
+23 ;
+24 SET VALMBCK="R"
SET VALM("TITLE")=TITLE
+25 QUIT
+26 ;
EXIT ;
+1 KILL ^TMP("PSOPMP0",$JOB),^TMP("PSOPMPSR",$JOB)
+2 QUIT
+3 ;
HELP QUIT
