PSOORFI3 ;BIR/RTR-finish CPRS orders by Clinic ;29-May-2012 14:58;PLS
;;7.0;OUTPATIENT PHARMACY;**15,27,32,46,84,99,130,117,139,172,1004,1005,225,300,1015**;DEC 1997;Build 62
;SC(-2675,40.8-728,51.2-2226,50.607-2221,55-2228,PSSLOCK-2789,DPT-10035,ORX2-867
;
; Modified - IHS/CIA/PLS - 03/23/04 - Fire VueCentric context change
; 10/06/05 - Moved VueCentric context change call to APSPFUNC
K ^TMP($J,"PSOCL"),^TMP($J,"PSOCLX"),PSOCLIN,PSOCLINF,PSOXINST
N PSOCFLAG,PSONPTRX,PSOINPTR,PSCLP,PSOCLINS,PSOSTC,PSOLGD,PSODIEN,PSOCTMP
K DIR S DIR(0)="SMB^C:CLINIC;S:SORT GROUP;E:EXIT",DIR("A")="Select By",DIR("B")="Clinic",DIR("?",1)="Enter 'C' to process orders for one individual Clinic,"
S DIR("?",2)=" 'S' to process orders for all Clinics associated with a Sort Group,",DIR("?",3)=" '^' or 'E' to exit" S DIR("?")=" "
W ! D ^DIR K DIR I $D(DTOUT)!($D(DUOUT))!(Y="E") W ! G EXIT
I Y="S" G SORT
CLIN W ! K DIC S DIC="^SC(",DIC(0)="QEAMZ",DIC("A")="Select CLINIC: " D ^DIC K DIC I Y<1!($D(DTOUT))!($D(DUOUT)) G EXIT
S PSOCLIN=+Y,PSOCLINF=1 D CHECK I $G(PSOCFLAG) D INSTNM^PSOORFI2 W !!,"You are signed in under the "_$G(PSODINST)_" CPRS Ordering",!,"Institution, which does not match the Institution for this Clinic!",! K PSODINST G CLIN
S ^TMP($J,"PSOCL",PSOCLIN)=PSOCLIN K PSOCLIN G START
SORT W ! K DIC S DIC="^PS(59.8,",DIC(0)="QEAMZ",DIC("A")="Select CLINIC SORT GROUP: " D ^DIC K DIC I Y<1!($D(DTOUT))!($D(DUOUT)) G EXIT
S PSOCLINS=+Y
K ^TMP($J,"PSOCL"),^TMP($J,"PSOCLX") F PSCLP=0:0 S PSCLP=$O(^PS(59.8,PSOCLINS,1,PSCLP)) Q:'PSCLP S PSOSTC=+$P($G(^PS(59.8,PSOCLINS,1,PSCLP,0)),"^") S:$G(PSOSTC)&($D(^SC(PSOSTC,0))) ^TMP($J,"PSOCL",PSOSTC)=PSOSTC
I '$O(^TMP($J,"PSOCL",0)) W !!,"There are no Clinics associated with this Sort Group!",! K ^TMP($J,"PSOCL") G SORT
F PSCLP=0:0 S PSCLP=$O(^TMP($J,"PSOCL",PSCLP)) Q:'PSCLP S PSOCLIN=PSCLP D CHECK I $G(PSOCFLAG) S ^TMP($J,"PSOCLX",PSCLP)=PSCLP K ^TMP($J,"PSOCL",PSCLP)
I $O(^TMP($J,"PSOCLX",0)) H 1 W @IOF W !,"Orders for these Clinics in the Sort Group will not be displayed for Finishing",!,"because the CPRS Ordering Institution does not match the Institution that is",!,"associated with the Clinic:",! D
.F PSCLP=0:0 S PSCLP=$O(^TMP($J,"PSOCLX",PSCLP)) Q:'PSCLP D:($Y+4)>IOSL W !,$P($G(^SC(PSCLP,0)),"^")
..W ! K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR W @IOF
I $O(^TMP($J,"PSOCLX",0)) D EOP
K ^TMP($J,"PSOCLX") I '$O(^TMP($J,"PSOCL",0)) W !!,"There are no Clinics that have a matching Institution!",! D EOP G SORT
;
S PSOCLINF=2
START K MEDP,MEDA,PSOQUIT,POERR("QFLG"),POERR("DFLG"),DIR
G:'$O(^TMP($J,"PSOCL",0)) EXIT
S PATA=0 F PSOCLIN=0:0 S PSOCLIN=$O(^TMP($J,"PSOCL",PSOCLIN)) Q:'PSOCLIN!($G(POERR("QFLG"))) F PSOLGD=0:0 S PSOLGD=$O(^PS(52.41,"ACL",PSOCLIN,PSOLGD)) Q:'PSOLGD!($G(POERR("QFLG"))) D
.F PSODIEN=0:0 S PSODIEN=$O(^PS(52.41,"ACL",PSOCLIN,PSOLGD,PSODIEN)) Q:'PSODIEN!($G(POERR("QFLG"))) D
..I $P($G(^PS(52.41,PSODIEN,0)),"^",3)'="NW",$P($G(^(0)),"^",3)'="RNW",$P($G(^(0)),"^",3)'="RF" Q
..I $G(PSOPINST)'=$P($G(^PS(52.41,PSODIEN,"INI")),"^") Q
..Q:$G(PAT($P(^PS(52.41,PSODIEN,0),"^",2)))=$P(^PS(52.41,PSODIEN,0),"^",2) S PAT=$P(^PS(52.41,PSODIEN,0),"^",2)
..I PAT'=PATA,$O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
..D LK^PSOORFIN 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^PSOORFIN Q
..S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(+$G(PAT),0)),"^"),PATA=PAT
..; IHS/CIA/PLS - 03/23/04 - Added line to fire patient context changed to VueCentric
..;IHS/CIA/PLS - 10/06/2005 Moved EHR context change call to APSPFUNC
..;S X="CIAVCXPT" X ^%ZOSF("TEST") I $T D SETCTX^CIAVCXPT(+PSODFN)
..D SETPTCX^APSPFUNC(+PSODFN)
..D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) K PSOFIN S POERR("QFLG")=0 S PSONOLCK=1,PSOPTLOK=PAT D OERR^PSORX1 S PSOFIN=1 D QU^PSOORFIN S X=PSOPTLOK D KLLP^PSOORFIN,ULP^PSOORFIN,KLL^PSOORFIN Q
..D SDFN^PSOORFIN 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^PSOORFIN 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"))) I '$P($G(^PS(52.41,ORD,0)),"^",23) D
...S PSODFN=PAT D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2)
...D LK1^PSOORFIN,ORD^PSOORFIN S X=PAT D ULP^PSOORFIN
I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
;
EXIT K ^TMP($J,"PSOCL"),^TMP($J,"PSOCLX"),PSOCLIN,PSOCLINF,PSOXINST G EX^PSOORFIN
Q
CHECK ; check Institution
K PSOXINST,PSOCFLAG
I $P($G(^SC(PSOCLIN,0)),"^",4),$P($G(^(0)),"^",4)'=$G(PSOPINST) S PSOCFLAG=1 Q
I $P($G(^SC(PSOCLIN,0)),"^",4) Q
S PSONPTRX=$P($G(^SC(PSOCLIN,0)),"^",15)
I '$G(PSONPTRX) S PSONPTRX=$O(^DG(40.8,0))
I '$G(DT) S DT=$$DT^XLFDT
S PSOINPTR=+$$SITE^VASITE(DT,PSONPTRX) I PSOINPTR'=$G(PSOPINST) S PSOCFLAG=1
Q
EOP W ! K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR
Q
L1 ;Lock single order
I '$G(ORD) Q
K PSOMSG D PSOL^PSSLOCK(+ORD_"S") I '$G(PSOMSG) W !!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"This Order is being edited by another person."),! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR
Q
UL1 ;Unlock single order
I '$G(ORD) Q
I '$D(^PS(52.41,ORD,0)) D Q
. D UNLK1^ORX2(+$G(OR0))
. Q
D PSOUL^PSSLOCK(+ORD_"S")
Q
DOSE ;pending orders
K DOENT S DS=1
F I=0:0 S I=$O(^PS(52.41,ORD,1,I)) Q:'I S DOSE=$G(^PS(52.41,ORD,1,I,1)),DOSE1=$G(^(2)) D D DOSE1
.S PSONEW("DOSE",I)=$P(DOSE1,"^"),PSONEW("DOSE ORDERED",I)=$P(DOSE1,"^",2),PSONEW("UNITS",I)=$P(DOSE,"^",9),PSONEW("NOUN",I)=$P(DOSE,"^",5)
.S:$P(DOSE,"^",9) UNITS=$P(^PS(50.607,$P(DOSE,"^",9),0),"^")
.S PSONEW("VERB",I)=$P(DOSE,"^",10),PSONEW("ROUTE",I)=$P(DOSE,"^",8)
.S:$P(DOSE,"^",8) ROUTE=$P(^PS(51.2,$P(DOSE,"^",8),0),"^")
.S PSONEW("SCHEDULE",I)=$P(DOSE,"^"),PSONEW("DURATION",I)=$P(DOSE,"^",2)
.S DOENT=$G(DOENT)+1 S PSONEW("CONJUNCTION",I)=$S($P(DOSE,"^",6)="A":"AND",$P(DOSE,"^",6)="S":"THEN",$P(DOSE,"^",6)="X":"EXCEPT",1:"")
.I 'PSONEW("DOSE ORDERED",I),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Verb: "_$G(PSONEW("VERB",I))
.S:$G(DS) IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3)"
S PSONEW("ENT")=DOENT K DOSE,DOSE1,I,UNITS,ROUTE,DOENT
Q
DOSE1 I $G(DS)=1 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_" *Dosage:" D FMD G DU
S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Dosage:" D FMD
DU I 'PSONEW("DOSE ORDERED",I),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I))
I PSONEW("DOSE ORDERED",I),$G(PSONEW("VERB",I))]"" D
.S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Verb: "_$G(PSONEW("VERB",I))
.S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Dispense Units: "_$S($E(PSONEW("DOSE ORDERED",I),1)=".":"0",1:"")_PSONEW("DOSE ORDERED",I)
I PSONEW("NOUN",I) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Noun: "_PSONEW("NOUN",I)
S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Route: "_$G(ROUTE)
S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Schedule: "_PSONEW("SCHEDULE",I)
I $P(DOSE,"^",2)]"" D
.S DUR=$S($E($P(DOSE,"^",2),1)'?.N:$E($P(DOSE,"^",2),2,99)_$E($P(DOSE,"^",2),1),1:$P(DOSE,"^",2))
.S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Duration: "_DUR_" ("_$S($P(DOSE,"^",2)["M":"MINUTES",$P(DOSE,"^",2)["H":"HOURS",$P(DOSE,"^",2)["L":"MONTHS",$P(DOSE,"^",2)["W":"WEEKS",1:"DAYS")_")"
I $P(DOSE,"^",6)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Conjunction: "_$S($P(DOSE,"^",6)="A":"AND",$P(DOSE,"^",6)="S":"THEN",$P(DOSE,"^",6)="X":"EXCEPT",1:"")
Q
DOSE2 ;displays pending order after edits
S DS=1
F I=1:1:PSONEW("ENT") Q:'I D D DOSE3 K COJ
.S:$G(PSONEW("UNITS",I))]"" UNITS=$P(^PS(50.607,PSONEW("UNITS",I),0),"^") S:$G(PSONEW("ROUTE",I))]"" ROUTE=$P(^PS(51.2,PSONEW("ROUTE",I),0),"^")
.S DUR=$G(PSONEW("DURATION",I)) S:$G(PSONEW("CONJUNCTION",I))]"" COJ=PSONEW("CONJUNCTION",I)
.S NOUN=PSONEW("NOUN",I),VERB=$G(PSONEW("VERB",I))
.I 'PSONEW("DOSE ORDERED",I),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I))
.I '$G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Verb: "_$G(PSONEW("VERB",I))
.S:$G(DS) IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3)"
K I,UNITS,ROUTE,DUR,COJ,VERB,NOUN
Q
DOSE3 I $G(DS)=1 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_" *Dosage:" D FMD G DO
S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Dosage:" D FMD
DO I 'PSONEW("DOSE ORDERED",I),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I))
I $G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Verb: "_$G(PSONEW("VERB",I))
I $G(PSONEW("DOSE ORDERED",I)) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Dispense Units: "_$S($E(PSONEW("DOSE ORDERED",I),1)=".":"0",1:"")_PSONEW("DOSE ORDERED",I)
I $G(PSONEW("DOSE ORDERED",I)) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" NOUN: "_PSONEW("NOUN",I)
S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Route: "_$G(ROUTE)
S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Schedule: "_PSONEW("SCHEDULE",I)
I $G(DUR)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Duration: "_DUR_" ("_$S(DUR["M":"MINUTES",DUR["H":"HOURS",DUR["L":"MONTHS",DUR["W":"WEEKS",1:"DAYS")_")"
I $G(COJ)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Conjunction: "_$S(COJ="A":"AND",COJ="T":"THEN",COJ="X":"EXCEPT",1:"")
Q
FMD Q:$G(PSONEW("DOSE",II))']"" S MIG=PSONEW("DOSE",II)
I $E(MIG,1)=".",$G(PSONEW("DOSE ORDERED",II)) S MIG="0"_MIG
F SG=1:1:$L(MIG," ") S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(MIG," ",SG)
I $G(UNITS)]"" S:$L(^TMP("PSOPO",$J,IEN,0)_" ("_UNITS_")")>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" ("_UNITS_")"
K DS,MIG,SG
I '$G(PSONEW("DOSE ORDERED",II)),$P($G(^PS(55,PSODFN,"LAN")),"^") D LAN^PSOORED5
Q
SQR ;
D SQR^PSOORFIN
Q
SQN ;
K MAXRF,PSOSIG,MPSDY,PSOMAX,STA,PSORX0,ORCHK,ORDRG
I $G(PSOQUIT) S PSOQQ=1 K PSOQUIT
Q
PSOORFI3 ;BIR/RTR-finish CPRS orders by Clinic ;29-May-2012 14:58;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**15,27,32,46,84,99,130,117,139,172,1004,1005,225,300,1015**;DEC 1997;Build 62
+2 ;SC(-2675,40.8-728,51.2-2226,50.607-2221,55-2228,PSSLOCK-2789,DPT-10035,ORX2-867
+3 ;
+4 ; Modified - IHS/CIA/PLS - 03/23/04 - Fire VueCentric context change
+5 ; 10/06/05 - Moved VueCentric context change call to APSPFUNC
+6 KILL ^TMP($JOB,"PSOCL"),^TMP($JOB,"PSOCLX"),PSOCLIN,PSOCLINF,PSOXINST
+7 NEW PSOCFLAG,PSONPTRX,PSOINPTR,PSCLP,PSOCLINS,PSOSTC,PSOLGD,PSODIEN,PSOCTMP
+8 KILL DIR
SET DIR(0)="SMB^C:CLINIC;S:SORT GROUP;E:EXIT"
SET DIR("A")="Select By"
SET DIR("B")="Clinic"
SET DIR("?",1)="Enter 'C' to process orders for one individual Clinic,"
+9 SET DIR("?",2)=" 'S' to process orders for all Clinics associated with a Sort Group,"
SET DIR("?",3)=" '^' or 'E' to exit"
SET DIR("?")=" "
+10 WRITE !
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!($DATA(DUOUT))!(Y="E")
WRITE !
GOTO EXIT
+11 IF Y="S"
GOTO SORT
CLIN WRITE !
KILL DIC
SET DIC="^SC("
SET DIC(0)="QEAMZ"
SET DIC("A")="Select CLINIC: "
DO ^DIC
KILL DIC
IF Y<1!($DATA(DTOUT))!($DATA(DUOUT))
GOTO EXIT
+1 SET PSOCLIN=+Y
SET PSOCLINF=1
DO CHECK
IF $GET(PSOCFLAG)
DO INSTNM^PSOORFI2
WRITE !!,"You are signed in under the "_$GET(PSODINST)_" CPRS Ordering",!,"Institution, which does not match the Institution for this Clinic!",!
KILL PSODINST
GOTO CLIN
+2 SET ^TMP($JOB,"PSOCL",PSOCLIN)=PSOCLIN
KILL PSOCLIN
GOTO START
SORT WRITE !
KILL DIC
SET DIC="^PS(59.8,"
SET DIC(0)="QEAMZ"
SET DIC("A")="Select CLINIC SORT GROUP: "
DO ^DIC
KILL DIC
IF Y<1!($DATA(DTOUT))!($DATA(DUOUT))
GOTO EXIT
+1 SET PSOCLINS=+Y
+2 KILL ^TMP($JOB,"PSOCL"),^TMP($JOB,"PSOCLX")
FOR PSCLP=0:0
SET PSCLP=$ORDER(^PS(59.8,PSOCLINS,1,PSCLP))
IF 'PSCLP
QUIT
SET PSOSTC=+$PIECE($GET(^PS(59.8,PSOCLINS,1,PSCLP,0)),"^")
IF $GET(PSOSTC)&($DATA(^SC(PSOSTC,0)))
SET ^TMP($JOB,"PSOCL",PSOSTC)=PSOSTC
+3 IF '$ORDER(^TMP($JOB,"PSOCL",0))
WRITE !!,"There are no Clinics associated with this Sort Group!",!
KILL ^TMP($JOB,"PSOCL")
GOTO SORT
+4 FOR PSCLP=0:0
SET PSCLP=$ORDER(^TMP($JOB,"PSOCL",PSCLP))
IF 'PSCLP
QUIT
SET PSOCLIN=PSCLP
DO CHECK
IF $GET(PSOCFLAG)
SET ^TMP($JOB,"PSOCLX",PSCLP)=PSCLP
KILL ^TMP($JOB,"PSOCL",PSCLP)
+5 IF $ORDER(^TMP($JOB,"PSOCLX",0))
HANG 1
WRITE @IOF
WRITE !,"Orders for these Clinics in the Sort Group will not be displayed for Finishing",!,"because the CPRS Ordering Institution does not match the Institution that is",!,"associated with the Clinic:",!
Begin DoDot:1
+6 FOR PSCLP=0:0
SET PSCLP=$ORDER(^TMP($JOB,"PSOCLX",PSCLP))
IF 'PSCLP
QUIT
IF ($Y+4)>IOSL
Begin DoDot:2
+7 WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
KILL DIR
WRITE @IOF
End DoDot:2
WRITE !,$PIECE($GET(^SC(PSCLP,0)),"^")
End DoDot:1
+8 IF $ORDER(^TMP($JOB,"PSOCLX",0))
DO EOP
+9 KILL ^TMP($JOB,"PSOCLX")
IF '$ORDER(^TMP($JOB,"PSOCL",0))
WRITE !!,"There are no Clinics that have a matching Institution!",!
DO EOP
GOTO SORT
+10 ;
+11 SET PSOCLINF=2
START KILL MEDP,MEDA,PSOQUIT,POERR("QFLG"),POERR("DFLG"),DIR
+1 IF '$ORDER(^TMP($JOB,"PSOCL",0))
GOTO EXIT
+2 SET PATA=0
FOR PSOCLIN=0:0
SET PSOCLIN=$ORDER(^TMP($JOB,"PSOCL",PSOCLIN))
IF 'PSOCLIN!($GET(POERR("QFLG")))
QUIT
FOR PSOLGD=0:0
SET PSOLGD=$ORDER(^PS(52.41,"ACL",PSOCLIN,PSOLGD))
IF 'PSOLGD!($GET(POERR("QFLG")))
QUIT
Begin DoDot:1
+3 FOR PSODIEN=0:0
SET PSODIEN=$ORDER(^PS(52.41,"ACL",PSOCLIN,PSOLGD,PSODIEN))
IF 'PSODIEN!($GET(POERR("QFLG")))
QUIT
Begin DoDot:2
+4 IF $PIECE($GET(^PS(52.41,PSODIEN,0)),"^",3)'="NW"
IF $PIECE($GET(^(0)),"^",3)'="RNW"
IF $PIECE($GET(^(0)),"^",3)'="RF"
QUIT
+5 IF $GET(PSOPINST)'=$PIECE($GET(^PS(52.41,PSODIEN,"INI")),"^")
QUIT
+6 IF $GET(PAT($PIECE(^PS(52.41,PSODIEN,0),"^",2)))=$PIECE(^PS(52.41,PSODIEN,0),"^",2)
QUIT
SET PAT=$PIECE(^PS(52.41,PSODIEN,0),"^",2)
+7 IF PAT'=PATA
IF $ORDER(PSORX("PSOL",0))!($DATA(RXRS))
DO LBL^PSOORFIN
+8 DO LK^PSOORFIN
IF $GET(POERR("QFLG"))
KILL POERR("QFLG")
SET PSOLK=1
SET PAT(PAT)=PAT
QUIT
+9 IF $$CHK^PSODPT(PAT_"^"_$PIECE($GET(^DPT(PAT,0)),"^"),1,1)<0
SET PSOLK=1
SET PAT(PAT)=PAT
SET X=PAT
DO ULP^PSOORFIN
QUIT
+10 SET (PSODFN,Y)=PAT_"^"_$PIECE($GET(^DPT(+$GET(PAT),0)),"^")
SET PATA=PAT
+11 ; IHS/CIA/PLS - 03/23/04 - Added line to fire patient context changed to VueCentric
+12 ;IHS/CIA/PLS - 10/06/2005 Moved EHR context change call to APSPFUNC
+13 ;S X="CIAVCXPT" X ^%ZOSF("TEST") I $T D SETCTX^CIAVCXPT(+PSODFN)
+14 DO SETPTCX^APSPFUNC(+PSODFN)
+15 IF '$GET(MEDA)
DO PROFILE^PSOORFI2
SET Y=PSODFN
IF $GET(MEDP)
KILL PSOFIN
SET POERR("QFLG")=0
SET PSONOLCK=1
SET PSOPTLOK=PAT
DO OERR^PSORX1
SET PSOFIN=1
DO QU^PSOORFIN
SET X=PSOPTLOK
DO KLLP^PSOORFIN
DO ULP^PSOORFIN
DO KLL^PSOORFIN
QUIT
+16 DO SDFN^PSOORFIN
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^PSOORFIN
KILL PSOQFLG
QUIT
+17 SET PAT(PAT)=PAT
+18 FOR ORD=0:0
SET ORD=$ORDER(^PS(52.41,"AOR",PAT,PSOPINST,ORD))
IF 'ORD!($GET(POERR("QFLG")))
QUIT
IF '$PIECE($GET(^PS(52.41,ORD,0)),"^",23)
Begin DoDot:3
+19 SET PSODFN=PAT
DO NOW^%DTC
SET TM=$EXTRACT(%,1,12)
SET TM1=$PIECE(TM,".",2)
+20 DO LK1^PSOORFIN
DO ORD^PSOORFIN
SET X=PAT
DO ULP^PSOORFIN
End DoDot:3
End DoDot:2
End DoDot:1
+21 IF $ORDER(PSORX("PSOL",0))!($DATA(RXRS))
DO LBL^PSOORFIN
+22 ;
EXIT KILL ^TMP($JOB,"PSOCL"),^TMP($JOB,"PSOCLX"),PSOCLIN,PSOCLINF,PSOXINST
GOTO EX^PSOORFIN
+1 QUIT
CHECK ; check Institution
+1 KILL PSOXINST,PSOCFLAG
+2 IF $PIECE($GET(^SC(PSOCLIN,0)),"^",4)
IF $PIECE($GET(^(0)),"^",4)'=$GET(PSOPINST)
SET PSOCFLAG=1
QUIT
+3 IF $PIECE($GET(^SC(PSOCLIN,0)),"^",4)
QUIT
+4 SET PSONPTRX=$PIECE($GET(^SC(PSOCLIN,0)),"^",15)
+5 IF '$GET(PSONPTRX)
SET PSONPTRX=$ORDER(^DG(40.8,0))
+6 IF '$GET(DT)
SET DT=$$DT^XLFDT
+7 SET PSOINPTR=+$$SITE^VASITE(DT,PSONPTRX)
IF PSOINPTR'=$GET(PSOPINST)
SET PSOCFLAG=1
+8 QUIT
EOP WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
KILL DIR
+1 QUIT
L1 ;Lock single order
+1 IF '$GET(ORD)
QUIT
+2 KILL PSOMSG
DO PSOL^PSSLOCK(+ORD_"S")
IF '$GET(PSOMSG)
WRITE !!,$SELECT($PIECE($GET(PSOMSG),"^",2)'="":$PIECE($GET(PSOMSG),"^",2),1:"This Order is being edited by another person."),!
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIR
+3 QUIT
UL1 ;Unlock single order
+1 IF '$GET(ORD)
QUIT
+2 IF '$DATA(^PS(52.41,ORD,0))
Begin DoDot:1
+3 DO UNLK1^ORX2(+$GET(OR0))
+4 QUIT
End DoDot:1
QUIT
+5 DO PSOUL^PSSLOCK(+ORD_"S")
+6 QUIT
DOSE ;pending orders
+1 KILL DOENT
SET DS=1
+2 FOR I=0:0
SET I=$ORDER(^PS(52.41,ORD,1,I))
IF 'I
QUIT
SET DOSE=$GET(^PS(52.41,ORD,1,I,1))
SET DOSE1=$GET(^(2))
Begin DoDot:1
+3 SET PSONEW("DOSE",I)=$PIECE(DOSE1,"^")
SET PSONEW("DOSE ORDERED",I)=$PIECE(DOSE1,"^",2)
SET PSONEW("UNITS",I)=$PIECE(DOSE,"^",9)
SET PSONEW("NOUN",I)=$PIECE(DOSE,"^",5)
+4 IF $PIECE(DOSE,"^",9)
SET UNITS=$PIECE(^PS(50.607,$PIECE(DOSE,"^",9),0),"^")
+5 SET PSONEW("VERB",I)=$PIECE(DOSE,"^",10)
SET PSONEW("ROUTE",I)=$PIECE(DOSE,"^",8)
+6 IF $PIECE(DOSE,"^",8)
SET ROUTE=$PIECE(^PS(51.2,$PIECE(DOSE,"^",8),0),"^")
+7 SET PSONEW("SCHEDULE",I)=$PIECE(DOSE,"^")
SET PSONEW("DURATION",I)=$PIECE(DOSE,"^",2)
+8 SET DOENT=$GET(DOENT)+1
SET PSONEW("CONJUNCTION",I)=$SELECT($PIECE(DOSE,"^",6)="A":"AND",$PIECE(DOSE,"^",6)="S":"THEN",$PIECE(DOSE,"^",6)="X":"EXCEPT",1:"")
+9 IF 'PSONEW("DOSE ORDERED",I)
IF $GET(PSONEW("VERB",I))]""
SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=" Verb: "_$GET(PSONEW("VERB",I))
+10 IF $GET(DS)
SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=" (3)"
End DoDot:1
DO DOSE1
+11 SET PSONEW("ENT")=DOENT
KILL DOSE,DOSE1,I,UNITS,ROUTE,DOENT
+12 QUIT
DOSE1 IF $GET(DS)=1
SET ^TMP("PSOPO",$JOB,IEN,0)=^TMP("PSOPO",$JOB,IEN,0)_" *Dosage:"
DO FMD
GOTO DU
+1 SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=" *Dosage:"
DO FMD
DU IF 'PSONEW("DOSE ORDERED",I)
IF $PIECE($GET(^PS(55,PSODFN,"LAN")),"^")
SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=" Oth. Lang. Dosage: "_$GET(PSONEW("ODOSE",I))
+1 IF PSONEW("DOSE ORDERED",I)
IF $GET(PSONEW("VERB",I))]""
Begin DoDot:1
+2 SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=" Verb: "_$GET(PSONEW("VERB",I))
+3 SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=" Dispense Units: "_$SELECT($EXTRACT(PSONEW("DOSE ORDERED",I),1)=".":"0",1:"")_PSONEW("DOSE ORDERED",I)
End DoDot:1
+4 IF PSONEW("NOUN",I)
SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=" Noun: "_PSONEW("NOUN",I)
+5 SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=" *Route: "_$GET(ROUTE)
+6 SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=" *Schedule: "_PSONEW("SCHEDULE",I)
+7 IF $PIECE(DOSE,"^",2)]""
Begin DoDot:1
+8 SET DUR=$SELECT($EXTRACT($PIECE(DOSE,"^",2),1)'?.N:$EXTRACT($PIECE(DOSE,"^",2),2,99)_$EXTRACT($PIECE(DOSE,"^",2),1),1:$PIECE(DOSE,"^",2))
+9 SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=" *Duration: "_DUR_" ("_$SELECT($PIECE(DOSE,"^",2)["M":"MINUTES",$PIECE(DOSE,"^",2)["H":"HOURS",$PIECE(DOSE,"^",2)["L":"MONTHS",$PIECE(DOSE,"^",2)["W":"WEEKS",1:"DAYS")_")"
End DoDot:1
+10 IF $PIECE(DOSE,"^",6)]""
SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=" *Conjunction: "_$SELECT($PIECE(DOSE,"^",6)="A":"AND",$PIECE(DOSE,"^",6)="S":"THEN",$PIECE(DOSE,"^",6)="X":"EXCEPT",1:"")
+11 QUIT
DOSE2 ;displays pending order after edits
+1 SET DS=1
+2 FOR I=1:1:PSONEW("ENT")
IF 'I
QUIT
Begin DoDot:1
+3 IF $GET(PSONEW("UNITS",I))]""
SET UNITS=$PIECE(^PS(50.607,PSONEW("UNITS",I),0),"^")
IF $GET(PSONEW("ROUTE",I))]""
SET ROUTE=$PIECE(^PS(51.2,PSONEW("ROUTE",I),0),"^")
+4 SET DUR=$GET(PSONEW("DURATION",I))
IF $GET(PSONEW("CONJUNCTION",I))]""
SET COJ=PSONEW("CONJUNCTION",I)
+5 SET NOUN=PSONEW("NOUN",I)
SET VERB=$GET(PSONEW("VERB",I))
+6 IF 'PSONEW("DOSE ORDERED",I)
IF $PIECE($GET(^PS(55,PSODFN,"LAN")),"^")
SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=" Oth. Lang. Dosage: "_$GET(PSONEW("ODOSE",I))
+7 IF '$GET(PSONEW("DOSE ORDERED",I))
IF $GET(PSONEW("VERB",I))]""
SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=" Verb: "_$GET(PSONEW("VERB",I))
+8 IF $GET(DS)
SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=" (3)"
End DoDot:1
DO DOSE3
KILL COJ
+9 KILL I,UNITS,ROUTE,DUR,COJ,VERB,NOUN
+10 QUIT
DOSE3 IF $GET(DS)=1
SET ^TMP("PSOPO",$JOB,IEN,0)=^TMP("PSOPO",$JOB,IEN,0)_" *Dosage:"
DO FMD
GOTO DO
+1 SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=" *Dosage:"
DO FMD
DO IF 'PSONEW("DOSE ORDERED",I)
IF $PIECE($GET(^PS(55,PSODFN,"LAN")),"^")
SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=" Oth. Lang. Dosage: "_$GET(PSONEW("ODOSE",I))
+1 IF $GET(PSONEW("DOSE ORDERED",I))
IF $GET(PSONEW("VERB",I))]""
SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=" Verb: "_$GET(PSONEW("VERB",I))
+2 IF $GET(PSONEW("DOSE ORDERED",I))
SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=" Dispense Units: "_$SELECT($EXTRACT(PSONEW("DOSE ORDERED",I),1)=".":"0",1:"")_PSONEW("DOSE ORDERED",I)
+3 IF $GET(PSONEW("DOSE ORDERED",I))
SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=" NOUN: "_PSONEW("NOUN",I)
+4 SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=" *Route: "_$GET(ROUTE)
+5 SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=" *Schedule: "_PSONEW("SCHEDULE",I)
+6 IF $GET(DUR)]""
SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=" *Duration: "_DUR_" ("_$SELECT(DUR["M":"MINUTES",DUR["H":"HOURS",DUR["L":"MONTHS",DUR["W":"WEEKS",1:"DAYS")_")"
+7 IF $GET(COJ)]""
SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=" *Conjunction: "_$SELECT(COJ="A":"AND",COJ="T":"THEN",COJ="X":"EXCEPT",1:"")
+8 QUIT
FMD IF $GET(PSONEW("DOSE",II))']""
QUIT
SET MIG=PSONEW("DOSE",II)
+1 IF $EXTRACT(MIG,1)="."
IF $GET(PSONEW("DOSE ORDERED",II))
SET MIG="0"_MIG
+2 FOR SG=1:1:$LENGTH(MIG," ")
IF $LENGTH(^TMP("PSOPO",$JOB,IEN,0)_" "_$PIECE(MIG," ",SG))>80
SET IEN=IEN+1
SET $PIECE(^TMP("PSOPO",$JOB,IEN,0)," ",20)=" "
SET ^TMP("PSOPO",$JOB,IEN,0)=$GET(^TMP("PSOPO",$JOB,IEN,0))_" "_$PIECE(MIG," ",SG)
+3 IF $GET(UNITS)]""
IF $LENGTH(^TMP("PSOPO",$JOB,IEN,0)_" ("_UNITS_")")>80
SET IEN=IEN+1
SET $PIECE(^TMP("PSOPO",$JOB,IEN,0)," ",20)=" "
SET ^TMP("PSOPO",$JOB,IEN,0)=$GET(^TMP("PSOPO",$JOB,IEN,0))_" ("_UNITS_")"
+4 KILL DS,MIG,SG
+5 IF '$GET(PSONEW("DOSE ORDERED",II))
IF $PIECE($GET(^PS(55,PSODFN,"LAN")),"^")
DO LAN^PSOORED5
+6 QUIT
SQR ;
+1 DO SQR^PSOORFIN
+2 QUIT
SQN ;
+1 KILL MAXRF,PSOSIG,MPSDY,PSOMAX,STA,PSORX0,ORCHK,ORDRG
+2 IF $GET(PSOQUIT)
SET PSOQQ=1
KILL PSOQUIT
+3 QUIT
