PSOORFI5 ;BIR/SJA-finish cprs orders ;29-May-2012 14:58;PLS
;;7.0;OUTPATIENT PHARMACY;**225,315,266,1015**;DEC 1997;Build 62
;External references UL^PSSLOCK supported by DBIA 2789
;External reference to ^DPT supported by DBIA 10035
;
;Modified - IHS/MSC/PLS - 5/10/2010 - Lines FLG+8 and PRI+14
;
FLG W ! K MEDP,MEDA,POERR("DFLG"),DIR D KQ S PSOSORT="FLAGGED^FLAGGED"
S LG=0,PATA=0 F S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG"))) F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG"))) D
.Q:'$D(^PS(52.41,PSOD,0))!('$P($G(^PS(52.41,PSOD,0)),"^",23))
.Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2) S PAT=$P(^PS(52.41,PSOD,0),"^",2)
.I PAT'=PATA,$O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
.D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
.I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG,PSOQQ Q
.S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT
.D SETPTCX^APSPFUNC(+PSODFN) ;IHS/MSC/PLS - 5/10/2010 - Added line to fire patient context change.
.D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q
.D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q
.S PAT(PAT)=PAT
.F ORD=0:0 S ORD=$O(^PS(52.41,"AOR",PAT,PSOPINST,ORD)) Q:'ORD!($G(POERR("QFLG")))!($G(PSOQQ)) D
..I $P($G(^PS(52.41,ORD,0)),"^",23) D PP,LK1,ORD^PSOORFIN
.S X=PAT D ULP K PSOQQ
I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
I $G(PSOQUIT) K PSOQUIT D EX G ^PSOORFIN
G EX
;
PRI ; Called from PSOORFIN due to it's routine size.
K DIR S PSOSORT="PRIORITY"
S DIR("A")="Select Priority",DIR(0)="SBM^S:STAT;E:EMERGENCY;R:ROUTINE",DIR("B")="ROUTINE"
D ^DIR G:$D(DIRUT) EX S PSOSORT=PSOSORT_"^"_Y,PSRT=Y
S LG=0,PATA=0 F S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG"))) F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG"))) D
.Q:$P($G(^PS(52.41,PSOD,0)),"^",23)
.Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2) S PAT=$P(^PS(52.41,PSOD,0),"^",2)
.;PSO*7*266
.I PAT'=PATA D LBL^PSOORFIN
.I '$O(^PS(52.41,"AP",PAT,PSRT,0)) S PSOLK=1,PAT(PAT)=PAT Q
.D PRI^PSOORFI2 I $G(PSZFIN) S PSOLK=1,PAT(PAT)=PAT Q
.D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
.I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP Q
.S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT
.D SETPTCX^APSPFUNC(+PSODFN) ;IHS/MSC/PLS - 5/10/2010 - Added line to fire patient context change.
.D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q
.D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q
.D PP S ORD=0 D @PSRT S PAT(PAT)=PAT
.S X=PAT D ULP
;PSO*7*266
D LBL^PSOORFIN
I $G(PSOQUIT) K PSOQUIT D EX G ^PSOORFIN
EX D EX^PSOORFI1
Q
LK D LOCK^PSOORFI1
Q
LK1 D LOCK1^PSOORFI1 Q
QU I $G(PSOQUIT) S POERR("QFLG")=1 K PSOQUIT
S:$G(PSOQFLG) PAT(PAT)=PAT
Q
ULP K PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
D CLEAN^PSOVER1
I '$G(X) Q
D UL^PSSLOCK(X) Q
KLL K PSOPTLOK
Q
KLLP K PSONOLCK
Q
SPL D SPL^PSOORFI4
Q
SDFN S PSODFN=+$G(PSODFN)
Q
PP D PP^PSOORFI4
Q
KQ K PSOQUIT,POERR("QFLG")
Q
S D S^PSOORFI2 ; Process STAT priority
Q
;
E D E^PSOORFI2 ; Process EMERGENCY priority
Q
;
R D R^PSOORFI2 ; Process ROUTINE priority
Q
;
LMDISP(ORD) ; Backdoor ListManager Display of Flag/Unflag Informaiton
N FLAG
K FLAGLINE S ORD=+$G(ORD) I 'ORD Q
;
I '$G(^PS(52.41,ORD,"FLG")) Q
; S X=IORVON_"Flagged"_IORVOFF
D GETS^DIQ(52.41,ORD,"33;34;35;36;37;38","IE","FLAG")
S L1="Flagged by "_$E(FLAG(52.41,ORD_",",34,"E"),1,30)_" on "_$$FMTE^XLFDT(FLAG(52.41,ORD_",",33,"I"),2)_": "
S LEN=80-$L(L1),L1=L1_$E(FLAG(52.41,ORD_",",35,"E"),1,LEN),L2=$E(FLAG(52.41,ORD_",",35,"E"),LEN+1,999)
S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=L1,FLAGLINE(IEN)=7
I L2'="" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=L2
I FLAG(52.41,ORD_",",36,"I")'="" D
. S L1="Unflagged by "_$E(FLAG(52.41,ORD_",",37,"E"),1,30)_" on "_$$FMTE^XLFDT(FLAG(52.41,ORD_",",36,"I"),2)_": "
. S LEN=80-$L(L1),L1=L1_$E(FLAG(52.41,ORD_",",38,"E"),1,LEN),L2=$E(FLAG(52.41,ORD_",",38,"E"),LEN+1,999)
. S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=L1,FLAGLINE(IEN)=9
. I L2'="" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=L2
S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" "
Q
PSOORFI5 ;BIR/SJA-finish cprs orders ;29-May-2012 14:58;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**225,315,266,1015**;DEC 1997;Build 62
+2 ;External references UL^PSSLOCK supported by DBIA 2789
+3 ;External reference to ^DPT supported by DBIA 10035
+4 ;
+5 ;Modified - IHS/MSC/PLS - 5/10/2010 - Lines FLG+8 and PRI+14
+6 ;
FLG WRITE !
KILL MEDP,MEDA,POERR("DFLG"),DIR
DO KQ
SET PSOSORT="FLAGGED^FLAGGED"
+1 SET LG=0
SET PATA=0
FOR
SET LG=$ORDER(^PS(52.41,"AD",LG))
IF 'LG!($GET(POERR("QFLG")))
QUIT
FOR PSOD=0:0
SET PSOD=$ORDER(^PS(52.41,"AD",LG,PSOPINST,PSOD))
IF 'PSOD!($GET(POERR("QFLG")))
QUIT
Begin DoDot:1
+2 IF '$DATA(^PS(52.41,PSOD,0))!('$PIECE($GET(^PS(52.41,PSOD,0)),"^",23))
QUIT
+3 IF $GET(PAT($PIECE(^PS(52.41,PSOD,0),"^",2)))=$PIECE(^PS(52.41,PSOD,0),"^",2)
QUIT
SET PAT=$PIECE(^PS(52.41,PSOD,0),"^",2)
+4 IF PAT'=PATA
IF $ORDER(PSORX("PSOL",0))!($DATA(RXRS))
DO LBL^PSOORFIN
+5 DO LK
IF $GET(POERR("QFLG"))
KILL POERR("QFLG")
SET PSOLK=1
SET PAT(PAT)=PAT
QUIT
+6 IF $$CHK^PSODPT(PAT_"^"_$PIECE($GET(^DPT(PAT,0)),"^"),1,1)<0
SET PSOLK=1
SET PAT(PAT)=PAT
SET X=PAT
DO ULP
KILL PSOQFLG,PSOQQ
QUIT
+7 SET (PSODFN,Y)=PAT_"^"_$PIECE($GET(^DPT(PAT,0)),"^")
SET PATA=PAT
+8 ;IHS/MSC/PLS - 5/10/2010 - Added line to fire patient context change.
DO SETPTCX^APSPFUNC(+PSODFN)
+9 IF '$GET(MEDA)
DO PROFILE^PSOORFI2
SET Y=PSODFN
IF $GET(MEDP)
DO SPL
DO OERR^PSORX1
SET PSOFIN=1
DO QU
SET X=PSOPTLOK
DO KLLP
DO ULP
DO KLL
QUIT
+10 DO SDFN
DO POST^PSOORFI1
IF $GET(PSOQFLG)!($GET(PSOQUIT))
IF $GET(PSOQUIT)
SET POERR("QFLG")=1
IF $GET(PSOQFLG)
SET PAT(PAT)=PAT
SET X=PAT
DO ULP
KILL PSOQFLG
QUIT
+11 SET PAT(PAT)=PAT
+12 FOR ORD=0:0
SET ORD=$ORDER(^PS(52.41,"AOR",PAT,PSOPINST,ORD))
IF 'ORD!($GET(POERR("QFLG")))!($GET(PSOQQ))
QUIT
Begin DoDot:2
+13 IF $PIECE($GET(^PS(52.41,ORD,0)),"^",23)
DO PP
DO LK1
DO ORD^PSOORFIN
End DoDot:2
+14 SET X=PAT
DO ULP
KILL PSOQQ
End DoDot:1
+15 IF $ORDER(PSORX("PSOL",0))!($DATA(RXRS))
DO LBL^PSOORFIN
+16 IF $GET(PSOQUIT)
KILL PSOQUIT
DO EX
GOTO ^PSOORFIN
+17 GOTO EX
+18 ;
PRI ; Called from PSOORFIN due to it's routine size.
+1 KILL DIR
SET PSOSORT="PRIORITY"
+2 SET DIR("A")="Select Priority"
SET DIR(0)="SBM^S:STAT;E:EMERGENCY;R:ROUTINE"
SET DIR("B")="ROUTINE"
+3 DO ^DIR
IF $DATA(DIRUT)
GOTO EX
SET PSOSORT=PSOSORT_"^"_Y
SET PSRT=Y
+4 SET LG=0
SET PATA=0
FOR
SET LG=$ORDER(^PS(52.41,"AD",LG))
IF 'LG!($GET(POERR("QFLG")))
QUIT
FOR PSOD=0:0
SET PSOD=$ORDER(^PS(52.41,"AD",LG,PSOPINST,PSOD))
IF 'PSOD!($GET(POERR("QFLG")))
QUIT
Begin DoDot:1
+5 IF $PIECE($GET(^PS(52.41,PSOD,0)),"^",23)
QUIT
+6 IF $GET(PAT($PIECE(^PS(52.41,PSOD,0),"^",2)))=$PIECE(^PS(52.41,PSOD,0),"^",2)
QUIT
SET PAT=$PIECE(^PS(52.41,PSOD,0),"^",2)
+7 ;PSO*7*266
+8 IF PAT'=PATA
DO LBL^PSOORFIN
+9 IF '$ORDER(^PS(52.41,"AP",PAT,PSRT,0))
SET PSOLK=1
SET PAT(PAT)=PAT
QUIT
+10 DO PRI^PSOORFI2
IF $GET(PSZFIN)
SET PSOLK=1
SET PAT(PAT)=PAT
QUIT
+11 DO LK
IF $GET(POERR("QFLG"))
KILL POERR("QFLG")
SET PSOLK=1
SET PAT(PAT)=PAT
QUIT
+12 IF $$CHK^PSODPT(PAT_"^"_$PIECE($GET(^DPT(PAT,0)),"^"),1,1)<0
SET PSOLK=1
SET PAT(PAT)=PAT
SET X=PAT
DO ULP
QUIT
+13 SET (PSODFN,Y)=PAT_"^"_$PIECE($GET(^DPT(PAT,0)),"^")
SET PATA=PAT
+14 ;IHS/MSC/PLS - 5/10/2010 - Added line to fire patient context change.
DO SETPTCX^APSPFUNC(+PSODFN)
+15 IF '$GET(MEDA)
DO PROFILE^PSOORFI2
SET Y=PSODFN
IF $GET(MEDP)
DO SPL
DO OERR^PSORX1
SET PSOFIN=1
DO QU
SET X=PSOPTLOK
DO KLLP
DO ULP
DO KLL
QUIT
+16 DO SDFN
DO POST^PSOORFI1
IF $GET(PSOQFLG)!($GET(PSOQUIT))
IF $GET(PSOQUIT)
SET POERR("QFLG")=1
IF $GET(PSOQFLG)
SET PAT(PAT)=PAT
SET X=PAT
DO ULP
KILL PSOQFLG
QUIT
+17 DO PP
SET ORD=0
DO @PSRT
SET PAT(PAT)=PAT
+18 SET X=PAT
DO ULP
End DoDot:1
+19 ;PSO*7*266
+20 DO LBL^PSOORFIN
+21 IF $GET(PSOQUIT)
KILL PSOQUIT
DO EX
GOTO ^PSOORFIN
EX DO EX^PSOORFI1
+1 QUIT
LK DO LOCK^PSOORFI1
+1 QUIT
LK1 DO LOCK1^PSOORFI1
QUIT
QU IF $GET(PSOQUIT)
SET POERR("QFLG")=1
KILL PSOQUIT
+1 IF $GET(PSOQFLG)
SET PAT(PAT)=PAT
+2 QUIT
ULP KILL PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
+1 DO CLEAN^PSOVER1
+2 IF '$GET(X)
QUIT
+3 DO UL^PSSLOCK(X)
QUIT
KLL KILL PSOPTLOK
+1 QUIT
KLLP KILL PSONOLCK
+1 QUIT
SPL DO SPL^PSOORFI4
+1 QUIT
SDFN SET PSODFN=+$GET(PSODFN)
+1 QUIT
PP DO PP^PSOORFI4
+1 QUIT
KQ KILL PSOQUIT,POERR("QFLG")
+1 QUIT
S ; Process STAT priority
DO S^PSOORFI2
+1 QUIT
+2 ;
E ; Process EMERGENCY priority
DO E^PSOORFI2
+1 QUIT
+2 ;
R ; Process ROUTINE priority
DO R^PSOORFI2
+1 QUIT
+2 ;
LMDISP(ORD) ; Backdoor ListManager Display of Flag/Unflag Informaiton
+1 NEW FLAG
+2 KILL FLAGLINE
SET ORD=+$GET(ORD)
IF 'ORD
QUIT
+3 ;
+4 IF '$GET(^PS(52.41,ORD,"FLG"))
QUIT
+5 ; S X=IORVON_"Flagged"_IORVOFF
+6 DO GETS^DIQ(52.41,ORD,"33;34;35;36;37;38","IE","FLAG")
+7 SET L1="Flagged by "_$EXTRACT(FLAG(52.41,ORD_",",34,"E"),1,30)_" on "_$$FMTE^XLFDT(FLAG(52.41,ORD_",",33,"I"),2)_": "
+8 SET LEN=80-$LENGTH(L1)
SET L1=L1_$EXTRACT(FLAG(52.41,ORD_",",35,"E"),1,LEN)
SET L2=$EXTRACT(FLAG(52.41,ORD_",",35,"E"),LEN+1,999)
+9 SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=L1
SET FLAGLINE(IEN)=7
+10 IF L2'=""
SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=L2
+11 IF FLAG(52.41,ORD_",",36,"I")'=""
Begin DoDot:1
+12 SET L1="Unflagged by "_$EXTRACT(FLAG(52.41,ORD_",",37,"E"),1,30)_" on "_$$FMTE^XLFDT(FLAG(52.41,ORD_",",36,"I"),2)_": "
+13 SET LEN=80-$LENGTH(L1)
SET L1=L1_$EXTRACT(FLAG(52.41,ORD_",",38,"E"),1,LEN)
SET L2=$EXTRACT(FLAG(52.41,ORD_",",38,"E"),LEN+1,999)
+14 SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=L1
SET FLAGLINE(IEN)=9
+15 IF L2'=""
SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=L2
End DoDot:1
+16 SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=" "
+17 QUIT
