- PSOORFI3 ;BIR/RTR-finish CPRS orders by Clinic ; 4/26/11 2:05pm
- ;;7.0;OUTPATIENT PHARMACY;**15,27,32,46,84,99,130,117,139,172,225,300,384,372,505,557,700**;DEC 1997;Build 261
- ;SC(-2675,40.8-728,51.2-2226,50.607-2221,55-2228,PSSLOCK-2789,DPT-10035,ORX2-867
- ;
- 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
- ;PSO*505 - added secondary sort
- N SECSORT,ERXIEN,EPATLCK,EPATIEN S SECSORT=$$DIR^PSOORFI6("CL:CLINIC")
- 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
- ..; MbM only: Checking whether the eRx Patient is locked on the eRx Holding Queue, if so, skip record
- ..S ERXIEN=$$ERXIEN^PSOERXUT(PSODIEN_"P")
- ..I $$GET1^DIQ(59.7,1,102,"I")="MBM",ERXIEN D I $G(EPATLCK) Q
- ...S EPATLCK=0,EPATIEN=+$$GET1^DIQ(52.49,ERXIEN,.04,"I") I 'EPATIEN Q
- ...I $$L^PSOERX1A(EPATIEN,1,1) D
- ....D UL^PSOERX1A(EPATIEN)
- ...E S EPATLCK=1
- ..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 K PSORX("DOSING OFF") I $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
- ..; PSO*505 - secondary sort check
- ..I SECSORT'=0,'$$CHKFLTR^PSOORFI6(PSODIEN,SECSORT) Q
- ..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"))) D
- ...I $P($G(^PS(52.41,ORD,0)),"^",23),$P(SECSORT,"^",1)'="FL" Q
- ...S PSODFN=PAT D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2)
- ...I SECSORT'=0,'$$CHKFLTR^PSOORFI6(ORD,SECSORT) Q
- ...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
- N SAVELKTM,MBMSITE
- ; Altering Lock Timout for MbM sites for this specific Lock to support volume eRx Processing
- S MBMSITE=$S($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
- I $G(MBMSITE) S SAVELKTM=DILOCKTM,DILOCKTM=.01
- 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
- I $G(MBMSITE) S DILOCKTM=SAVELKTM
- 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 ROUTE="" S:$P(DOSE,"^",8) ROUTE=$P(^PS(51.2,$P(DOSE,"^",8),0),"^") ;PSO*7*384
- .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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOORFI3 10894 printed Feb 18, 2025@23:58:26 Page 2
- PSOORFI3 ;BIR/RTR-finish CPRS orders by Clinic ; 4/26/11 2:05pm
- +1 ;;7.0;OUTPATIENT PHARMACY;**15,27,32,46,84,99,130,117,139,172,225,300,384,372,505,557,700**;DEC 1997;Build 261
- +2 ;SC(-2675,40.8-728,51.2-2226,50.607-2221,55-2228,PSSLOCK-2789,DPT-10035,ORX2-867
- +3 ;
- +4 KILL ^TMP($JOB,"PSOCL"),^TMP($JOB,"PSOCLX"),PSOCLIN,PSOCLINF,PSOXINST
- +5 NEW PSOCFLAG,PSONPTRX,PSOINPTR,PSCLP,PSOCLINS,PSOSTC,PSOLGD,PSODIEN,PSOCTMP
- +6 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,"
- +7 SET DIR("?",2)=" 'S' to process orders for all Clinics associated with a Sort Group,"
- SET DIR("?",3)=" '^' or 'E' to exit"
- SET DIR("?")=" "
- +8 WRITE !
- DO ^DIR
- KILL DIR
- IF $DATA(DTOUT)!($DATA(DUOUT))!(Y="E")
- WRITE !
- GOTO EXIT
- +9 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 ;PSO*505 - added secondary sort
- +3 NEW SECSORT,ERXIEN,EPATLCK,EPATIEN
- SET SECSORT=$$DIR^PSOORFI6("CL:CLINIC")
- +4 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
- +5 FOR PSODIEN=0:0
- SET PSODIEN=$ORDER(^PS(52.41,"ACL",PSOCLIN,PSOLGD,PSODIEN))
- if 'PSODIEN!($GET(POERR("QFLG")))
- QUIT
- Begin DoDot:2
- +6 ; MbM only: Checking whether the eRx Patient is locked on the eRx Holding Queue, if so, skip record
- +7 SET ERXIEN=$$ERXIEN^PSOERXUT(PSODIEN_"P")
- +8 IF $$GET1^DIQ(59.7,1,102,"I")="MBM"
- IF ERXIEN
- Begin DoDot:3
- +9 SET EPATLCK=0
- SET EPATIEN=+$$GET1^DIQ(52.49,ERXIEN,.04,"I")
- IF 'EPATIEN
- QUIT
- +10 IF $$L^PSOERX1A(EPATIEN,1,1)
- Begin DoDot:4
- +11 DO UL^PSOERX1A(EPATIEN)
- End DoDot:4
- +12 IF '$TEST
- SET EPATLCK=1
- End DoDot:3
- IF $GET(EPATLCK)
- QUIT
- +13 IF $PIECE($GET(^PS(52.41,PSODIEN,0)),"^",3)'="NW"
- IF $PIECE($GET(^(0)),"^",3)'="RNW"
- IF $PIECE($GET(^(0)),"^",3)'="RF"
- QUIT
- +14 IF $GET(PSOPINST)'=$PIECE($GET(^PS(52.41,PSODIEN,"INI")),"^")
- QUIT
- +15 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)
- +16 IF PAT'=PATA
- KILL PSORX("DOSING OFF")
- IF $ORDER(PSORX("PSOL",0))!($DATA(RXRS))
- DO LBL^PSOORFIN
- +17 DO LK^PSOORFIN
- IF $GET(POERR("QFLG"))
- KILL POERR("QFLG")
- SET PSOLK=1
- SET PAT(PAT)=PAT
- QUIT
- +18 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
- +19 SET (PSODFN,Y)=PAT_"^"_$PIECE($GET(^DPT(+$GET(PAT),0)),"^")
- SET PATA=PAT
- +20 ; PSO*505 - secondary sort check
- +21 IF SECSORT'=0
- IF '$$CHKFLTR^PSOORFI6(PSODIEN,SECSORT)
- QUIT
- +22 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
- +23 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
- +24 SET PAT(PAT)=PAT
- +25 FOR ORD=0:0
- SET ORD=$ORDER(^PS(52.41,"AOR",PAT,PSOPINST,ORD))
- if 'ORD!($GET(POERR("QFLG")))
- QUIT
- Begin DoDot:3
- +26 IF $PIECE($GET(^PS(52.41,ORD,0)),"^",23)
- IF $PIECE(SECSORT,"^",1)'="FL"
- QUIT
- +27 SET PSODFN=PAT
- DO NOW^%DTC
- SET TM=$EXTRACT(%,1,12)
- SET TM1=$PIECE(TM,".",2)
- +28 IF SECSORT'=0
- IF '$$CHKFLTR^PSOORFI6(ORD,SECSORT)
- QUIT
- +29 DO LK1^PSOORFIN
- DO ORD^PSOORFIN
- SET X=PAT
- DO ULP^PSOORFIN
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +30 IF $ORDER(PSORX("PSOL",0))!($DATA(RXRS))
- DO LBL^PSOORFIN
- +31 ;
- 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 NEW SAVELKTM,MBMSITE
- +3 ; Altering Lock Timout for MbM sites for this specific Lock to support volume eRx Processing
- +4 SET MBMSITE=$SELECT($$GET1^DIQ(59.7,1,102,"I")="MBM":1,1:0)
- +5 IF $GET(MBMSITE)
- SET SAVELKTM=DILOCKTM
- SET DILOCKTM=.01
- +6 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
- +7 IF $GET(MBMSITE)
- SET DILOCKTM=SAVELKTM
- +8 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 ;PSO*7*384
- SET ROUTE=""
- 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