Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOORFI5

PSOORFI5.m

Go to the documentation of this file.
PSOORFI5 ;BIR/SJA-finish cprs orders ; 8/27/08 4:47pm
 ;;7.0;OUTPATIENT PHARMACY;**225,315,266,391,372,416,504,505,557**;DEC 1997;Build 7
 ;External references UL^PSSLOCK supported by DBIA 2789
 ;External reference to ^DPT supported by DBIA 10035
 ;
FLG W ! K MEDP,MEDA,POERR("DFLG"),DIR D KQ S PSOSORT="FLAGGED^FLAGGED"
 N SECSORT S SECSORT=$$DIR^PSOORFI6("FL:FLAGGED","FLAGGED") Q:SECSORT=U
 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 K PSORX("DOSING OFF") I $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
 .I SECSORT'=0,'$$CHKFLTR^PSOORFI6(PSOD,SECSORT) Q
 .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 SECSORT'=0,'$$CHKFLTR^PSOORFI6(ORD,SECSORT) Q
 ..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
 ;
SUP W ! K MEDP,MEDA,POERR("DFLG"),DIR D KQ S PSOSORT="SUPPLY^SUPPLY"
 N SECSORT S SECSORT=$$DIR^PSOORFI6("SU:SUPPLY","SUPPLY") Q:SECSORT=U
 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))!('$$ISSUPPLY^PSOORFI6(PSOD))
 .I SECSORT'=0,'$$CHKFLTR^PSOORFI6(PSOD,SECSORT) Q
 .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 K PSORX("DOSING OFF") I $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:'$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),$P(SECSORT,"^",1)'="FL" Q
 ..Q:'$$ISSUPPLY^PSOORFI6(ORD)
 ..I SECSORT'=0,'$$CHKFLTR^PSOORFI6(ORD,SECSORT) Q
 ..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
 Q
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
 N SECSORT S SECSORT=$$DIR^PSOORFI6("PR:PRIORITY",Y) Q:SECSORT=U
 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
 .I $P($G(^PS(52.41,PSOD,0)),"^",23),$P(SECSORT,"^",1)'="FL" Q
 .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 K PSORX("DOSING OFF") 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
 .I SECSORT'=0,'$$CHKFLTR^PSOORFI6(PSOD,SECSORT) Q
 .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 Information
 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
 ;
CS ; Digitally Signed CS - PSO*7*391
 K DIR N PSOCSRT S DIR("A")="Route",DIR(0)="SBM^W:WINDOW;M:MAIL;B:BOTH;E:EXIT",DIR("B")="BOTH" D ^DIR
 Q:$D(DIRUT)!(Y="E")
 S PSOCSRT=$S(Y="B":1,1:Y)
 W !!,"Select a schedule(s)"
 K DIR S PSOSORT="DIGITALLY SIGNED"
 S DIR("A")="Select Schedule(s)",DIR(0)="S^1:SCHEDULE II;2:SCHEDULES III - V;3:SCHEDULES II - V;4:NON-CS+SCHEDULES III - V;5:NON-CS ONLY;E:EXIT",DIR("B")=3
 D ^DIR G:$D(DIRUT)!(Y="E") EX S PSOSORT=PSOSORT_"^"_Y,PSRT=Y
 N SECSORT S SECSORT=$$DIR^PSOORFI6("CS:CONTROLLED SUBSTANCES",Y) Q:SECSORT=U
 N PDEA,OR0 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))
 .S OR0=^PS(52.41,PSOD,0)
 .;PSO*7*505 - still quit if the order is flagged, but now only look for digital signature if the selection does not ask for non contolled substances
 .I $P(OR0,"^",23),$P(SECSORT,"^",1)'="FL" Q
 .S PDEA=0 D PDEA Q:'PDEA!(PDEA'=PSRT)
 .;PSO*7*505 moved digitally signed check after the DEA check
 .I PSRT<4,'$P(OR0,"^",24) Q
 .I 'PSOCSRT,PSOCSRT'=$P(OR0,"^",17) Q
 .Q:$G(PAT($P(OR0,"^",2)))=$P(OR0,"^",2)  S PAT=$P(OR0,"^",2)
 .I PAT'=PATA K PSORX("DOSING OFF") I $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
 .I SECSORT'=0,'$$CHKFLTR^PSOORFI6(PSOD,SECSORT) Q
 .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
 ..Q:'$D(^PS(52.41,ORD,0))
 ..S OR0=^PS(52.41,ORD,0)
 ..;PSO*505 - Move the check for digitally signed, so non-cs substances will be shown if selected as sort criteria
 ..I $P(OR0,U,23),$P(SECSORT,"^",1)'="FL" Q
 ..I SECSORT'=0,'$$CHKFLTR^PSOORFI6(ORD,SECSORT) Q
 ..I 'PSOCSRT,PSOCSRT'=$P(OR0,"^",17) Q
 ..Q:$P(OR0,"^",3)="DC"!($P(OR0,"^",3)="DE")
 ..S PDEA=0 D PDEA Q:'PDEA!(PDEA'=PSRT)
 ..I PSRT<4,'$P(OR0,"^",24) Q
 ..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
 ;
PDEA ;
 I +$P(OR0,"^",9) S PDEA=$P($G(^PSDRUG($P(OR0,"^",9),0)),"^",3),PDEA=$S(PDEA[2:1,PDEA[3!(PDEA[4)!(PDEA[5):2,1:0)
 E  S PDEA=$$OIDEA^PSSUTLA1($P(OR0,"^",8),"O")
 ; PSO*7*505 - adding checks for new sort criteria
 ; PDEA=0 OR 2, covers non-cs and schedule 3-5
 I (PDEA=0)!(PDEA=2),PSRT=4 S PDEA=4 Q
 I PDEA=0,PSRT=5 S PDEA=5 Q
 ; PSO*7*505 end
 I PDEA,PSRT=3 S PDEA=3
 Q
 ;
PRV(PROV,DRG,ORN) ;
 N DETN,DEA,I,LBL,VADD,SPC
 I PROV="" Q
 S DEA=$S($G(ORN):$$RXDEA^PSOUTIL(,ORN),1:$$DEA^XUSER(0,PROV))
 S LBL=$S(DEA["-":" VA#: ",1:"DEA#: ") I $G(ADDS) S LBL=" "_LBL
 I DRG,$$DETOX^PSSOPKI(DRG) S DETN=$S($G(ORN):$$RXDETOX^PSOUTIL(,ORN),1:$$DETOX^XUSER(PROV))
 S $P(SPC," ",($S($G(ADDS):30,1:33)-$L(DEA)))=" "
 I (DEA'="")!($G(DETN)'="") S IEN=IEN+1,$E(^TMP("PSOPO",$J,IEN,0),16)=LBL_DEA_$S($G(DETN)]"":SPC_"DETOX#: "_$G(DETN),1:"")
 I $G(ORN) D PRVAD^PSOPKIV2 I $G(VADD(1))]"" D
 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=$S($G(ADDS):" ",1:"")_"       Site Address: "_VADD(1)
 .S:VADD(2)'="" IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=$S($G(ADDS):" ",1:"")_"                     "_VADD(2) S:VADD(3)'="" IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=$S($G(ADDS):" ",1:"")_"                     "_VADD(3)
 Q
 ;