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.
  1. PSOORFI5 ;BIR/SJA - finish cprs orders ;Oct 21, 2022@11:13
  1. ;;7.0;OUTPATIENT PHARMACY;**225,315,266,391,372,416,504,505,557,617,441,545,743**;DEC 1997;Build 24
  1. ;External references UL^PSSLOCK supported by DBIA 2789
  1. ;External reference to ^DPT supported by DBIA 10035
  1. ;External reference to ^PSSUTLA1 supported by DBIA 3373
  1. ;
  1. FLG W ! K MEDP,MEDA,POERR("DFLG"),DIR D KQ S PSOSORT="FLAGGED^FLAGGED"
  1. N SECSORT S SECSORT=$$DIR^PSOORFI6("FL:FLAGGED","FLAGGED") Q:SECSORT=U
  1. 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
  1. .Q:'$D(^PS(52.41,PSOD,0))!('$P($G(^PS(52.41,PSOD,0)),"^",23))
  1. .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)
  1. .I PAT'=PATA K PSORX("DOSING OFF") I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
  1. .D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
  1. .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
  1. .S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT
  1. .I SECSORT'=0,'$$CHKFLTR^PSOORFI6(PSOD,SECSORT) Q
  1. .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
  1. .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
  1. .S PAT(PAT)=PAT
  1. .F ORD=0:0 S ORD=$O(^PS(52.41,"AOR",PAT,PSOPINST,ORD)) Q:'ORD!($G(POERR("QFLG")))!($G(PSOQQ)) D
  1. ..I SECSORT'=0,'$$CHKFLTR^PSOORFI6(ORD,SECSORT) Q
  1. ..I $P($G(^PS(52.41,ORD,0)),"^",23) D PP,LK1,ORD^PSOORFIN
  1. .S X=PAT D ULP K PSOQQ
  1. I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
  1. I $G(PSOQUIT) K PSOQUIT D EX G ^PSOORFIN
  1. G EX
  1. ;
  1. SUP W ! K MEDP,MEDA,POERR("DFLG"),DIR D KQ S PSOSORT="SUPPLY^SUPPLY"
  1. N SECSORT S SECSORT=$$DIR^PSOORFI6("SU:SUPPLY","SUPPLY") Q:SECSORT=U
  1. 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
  1. .Q:'$D(^PS(52.41,PSOD,0))!('$$ISSUPPLY^PSOORFI6(PSOD))
  1. .I SECSORT'=0,'$$CHKFLTR^PSOORFI6(PSOD,SECSORT) Q
  1. .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)
  1. .I PAT'=PATA K PSORX("DOSING OFF") I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
  1. .D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
  1. .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
  1. .S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT
  1. .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
  1. .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
  1. .S PAT(PAT)=PAT
  1. .F ORD=0:0 S ORD=$O(^PS(52.41,"AOR",PAT,PSOPINST,ORD)) Q:'ORD!($G(POERR("QFLG")))!($G(PSOQQ)) D
  1. ..I $P($G(^PS(52.41,ORD,0)),"^",23),$P(SECSORT,"^",1)'="FL" Q
  1. ..Q:'$$ISSUPPLY^PSOORFI6(ORD)
  1. ..I SECSORT'=0,'$$CHKFLTR^PSOORFI6(ORD,SECSORT) Q
  1. ..D PP,LK1,ORD^PSOORFIN
  1. .S X=PAT D ULP K PSOQQ
  1. I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
  1. I $G(PSOQUIT) K PSOQUIT D EX G ^PSOORFIN
  1. G EX
  1. Q
  1. PRI ; Called from PSOORFIN due to it's routine size.
  1. K DIR S PSOSORT="PRIORITY"
  1. S DIR("A")="Select Priority",DIR(0)="SBM^S:STAT;E:EMERGENCY;R:ROUTINE",DIR("B")="ROUTINE"
  1. D ^DIR G:$D(DIRUT) EX S PSOSORT=PSOSORT_"^"_Y,PSRT=Y
  1. N SECSORT S SECSORT=$$DIR^PSOORFI6("PR:PRIORITY",Y) Q:SECSORT=U
  1. 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
  1. .I $P($G(^PS(52.41,PSOD,0)),"^",23),$P(SECSORT,"^",1)'="FL" Q
  1. .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)
  1. .;PSO*7*266
  1. .I PAT'=PATA K PSORX("DOSING OFF") D LBL^PSOORFIN
  1. .I '$O(^PS(52.41,"AP",PAT,PSRT,0)) S PSOLK=1,PAT(PAT)=PAT Q
  1. .D PRI^PSOORFI2 I $G(PSZFIN) S PSOLK=1,PAT(PAT)=PAT Q
  1. .D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
  1. .I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP Q
  1. .S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT
  1. .I SECSORT'=0,'$$CHKFLTR^PSOORFI6(PSOD,SECSORT) Q
  1. .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
  1. .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
  1. .D PP S ORD=0 D @PSRT S PAT(PAT)=PAT
  1. .S X=PAT D ULP
  1. ;PSO*7*266
  1. D LBL^PSOORFIN
  1. I $G(PSOQUIT) K PSOQUIT D EX G ^PSOORFIN
  1. EX D EX^PSOORFI1
  1. Q
  1. LK D LOCK^PSOORFI1
  1. Q
  1. LK1 D LOCK1^PSOORFI1 Q
  1. QU I $G(PSOQUIT) S POERR("QFLG")=1 K PSOQUIT
  1. S:$G(PSOQFLG) PAT(PAT)=PAT
  1. Q
  1. ULP K PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
  1. D CLEAN^PSOVER1
  1. I '$G(X) Q
  1. D UL^PSSLOCK(X) Q
  1. KLL K PSOPTLOK
  1. Q
  1. KLLP K PSONOLCK
  1. Q
  1. SPL D SPL^PSOORFI4
  1. Q
  1. SDFN S PSODFN=+$G(PSODFN)
  1. Q
  1. PP D PP^PSOORFI4
  1. Q
  1. KQ K PSOQUIT,POERR("QFLG")
  1. Q
  1. S D S^PSOORFI2 ; Process STAT priority
  1. Q
  1. ;
  1. E D E^PSOORFI2 ; Process EMERGENCY priority
  1. Q
  1. ;
  1. R D R^PSOORFI2 ; Process ROUTINE priority
  1. Q
  1. ;
  1. LMDISP(ORD) ; Backdoor ListManager Display of Flag/Unflag Information
  1. N FLAG
  1. K FLAGLINE S ORD=+$G(ORD) I 'ORD Q
  1. ;
  1. I '$G(^PS(52.41,ORD,"FLG")) Q
  1. ; S X=IORVON_"Flagged"_IORVOFF
  1. D GETS^DIQ(52.41,ORD,"33;34;35;36;37;38","IE","FLAG")
  1. S L1="Flagged by "_$E(FLAG(52.41,ORD_",",34,"E"),1,30)_" on "_$$FMTE^XLFDT(FLAG(52.41,ORD_",",33,"I"),2)_": "
  1. 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)
  1. S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=L1,FLAGLINE(IEN)=7
  1. I L2'="" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=L2
  1. I FLAG(52.41,ORD_",",36,"I")'="" D
  1. . S L1="Unflagged by "_$E(FLAG(52.41,ORD_",",37,"E"),1,30)_" on "_$$FMTE^XLFDT(FLAG(52.41,ORD_",",36,"I"),2)_": "
  1. . 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)
  1. . S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=L1,FLAGLINE(IEN)=9
  1. . I L2'="" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=L2
  1. S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" "
  1. Q
  1. ;
  1. CS ; Digitally Signed CS - PSO*7*391
  1. K DIR
  1. N PSOCSRT,PSOPARKX,RESULTS,Y
  1. S DIR("A")="Route",DIR(0)="SBM^W:WINDOW;M:MAIL;B:BOTH;E:EXIT",DIR("B")="BOTH"
  1. S RESULTS="PSOPARKX" D GETPARK^PSORPC01()
  1. I $G(PSOPARKX(0))="YES" S DIR(0)="SBM^W:WINDOW;M:MAIL;P:PARK;A:ALL;E:EXIT",DIR("B")="ALL"
  1. D ^DIR
  1. Q:$D(DIRUT)!(Y="E")
  1. S PSOCSRT=$S(Y="A":1,Y="B":1,1:Y)
  1. W !!,"Select a schedule(s)"
  1. K DIR S PSOSORT="DIGITALLY SIGNED"
  1. 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
  1. D ^DIR G:$D(DIRUT)!(Y="E") EX S PSOSORT=PSOSORT_"^"_Y,PSRT=Y
  1. N SECSORT S SECSORT=$$DIR^PSOORFI6("CS:CONTROLLED SUBSTANCES",Y) Q:SECSORT=U
  1. 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
  1. .Q:'$D(^PS(52.41,PSOD,0))
  1. .S OR0=^PS(52.41,PSOD,0)
  1. .;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
  1. .I $P(OR0,"^",23),$P(SECSORT,"^",1)'="FL" Q
  1. .S PDEA=0 D PDEA Q:'PDEA!(PDEA'=PSRT)
  1. .;PSO*7*505 moved digitally signed check after the DEA check (Disregards eRx Pending orders)
  1. .I PSRT<4,'$$ERXIEN^PSOERXUT(PSOD_"P"),'$P(OR0,"^",24) Q
  1. .I 'PSOCSRT,PSOCSRT'=$P(OR0,"^",17) Q
  1. .Q:$G(PAT($P(OR0,"^",2)))=$P(OR0,"^",2) S PAT=$P(OR0,"^",2)
  1. .I PAT'=PATA K PSORX("DOSING OFF") I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
  1. .D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
  1. .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
  1. .S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT
  1. .I SECSORT'=0,'$$CHKFLTR^PSOORFI6(PSOD,SECSORT) Q
  1. .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
  1. .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
  1. .S PAT(PAT)=PAT
  1. .F ORD=0:0 S ORD=$O(^PS(52.41,"AOR",PAT,PSOPINST,ORD)) Q:'ORD!($G(POERR("QFLG")))!($G(PSOQQ)) D
  1. ..Q:'$D(^PS(52.41,ORD,0))
  1. ..S OR0=^PS(52.41,ORD,0)
  1. ..;PSO*505 - Move the check for digitally signed, so non-cs substances will be shown if selected as sort criteria
  1. ..I $P(OR0,U,23),$P(SECSORT,"^",1)'="FL" Q
  1. ..I SECSORT'=0,'$$CHKFLTR^PSOORFI6(ORD,SECSORT) Q
  1. ..I 'PSOCSRT,PSOCSRT'=$P(OR0,"^",17) Q
  1. ..Q:$P(OR0,"^",3)="DC"!($P(OR0,"^",3)="DE")
  1. ..S PDEA=0 D PDEA Q:'PDEA!(PDEA'=PSRT)
  1. ..I PSRT<4,'$$ERXIEN^PSOERXUT(ORD_"P"),'$P(OR0,"^",24) Q
  1. ..D PP,LK1,ORD^PSOORFIN
  1. .S X=PAT D ULP K PSOQQ
  1. I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
  1. I $G(PSOQUIT) K PSOQUIT D EX G ^PSOORFIN
  1. G EX
  1. ;
  1. PDEA ;
  1. 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)
  1. E S PDEA=$$OIDEA^PSSUTLA1($P(OR0,"^",8),"O")
  1. ; PSO*7*505 - adding checks for new sort criteria
  1. ; PDEA=0 OR 2, covers non-cs and schedule 3-5
  1. I (PDEA=0)!(PDEA=2),PSRT=4 S PDEA=4 Q
  1. I PDEA=0,PSRT=5 S PDEA=5 Q
  1. ; PSO*7*505 end
  1. I PDEA,PSRT=3 S PDEA=3
  1. Q
  1. ;
  1. PRV(PROV,DRG,ORN) ;
  1. N DETN,DEA,I,LBL,VADD,SPC
  1. I PROV="" Q
  1. ;*545 - show DEA label only, get the stored DEA#
  1. S:$L($G(PSORX("RXDEA"))) DEA=PSORX("RXDEA")
  1. ;If renew, try to get DEA from the renewal from CPRS rather than the original RX, provider may have changed
  1. I $G(PSOORRNW),$G(ORN) S DEA=$$RXDEA^PSOUTIL(,ORN)
  1. I '$L($G(DEA)) S DEA=$S($G(PSONEW("OIRXN")):$$RXDEA^PSOUTIL(PSONEW("OIRXN")),$G(ORN):$$RXDEA^PSOUTIL(,ORN),1:$$DEA^XUSER(0,PROV)) S:DEA]"" PSORX("RXDEA")=DEA
  1. S:$L($G(PSORX("DETX"))) DETN=PSORX("DETX")
  1. S LBL="DEA#: " I $G(ADDS) S LBL=" "_LBL
  1. I DRG,$$DETOX^PSSOPKI(DRG),'$L($G(DETN)) S DETN=$S($G(ORN):$$RXDETOX^PSOUTIL(,ORN),1:$$DETOX^XUSER(PROV))
  1. S $P(SPC," ",($S($G(ADDS):30,1:33)-$L(DEA)))=" "
  1. 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:"")
  1. I $G(ORN) D PRVAD^PSOPKIV2 I $G(VADD(1))]"" D
  1. .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=$S($G(ADDS):" ",1:"")_" Site Address: "_VADD(1)
  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)
  1. Q