- PSOORFI5 ;BIR/SJA - finish cprs orders ;Oct 21, 2022@11:13
- ;;7.0;OUTPATIENT PHARMACY;**225,315,266,391,372,416,504,505,557,617,441,545,743**;DEC 1997;Build 24
- ;External references UL^PSSLOCK supported by DBIA 2789
- ;External reference to ^DPT supported by DBIA 10035
- ;External reference to ^PSSUTLA1 supported by DBIA 3373
- ;
- 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,PSOPARKX,RESULTS,Y
- S DIR("A")="Route",DIR(0)="SBM^W:WINDOW;M:MAIL;B:BOTH;E:EXIT",DIR("B")="BOTH"
- S RESULTS="PSOPARKX" D GETPARK^PSORPC01()
- I $G(PSOPARKX(0))="YES" S DIR(0)="SBM^W:WINDOW;M:MAIL;P:PARK;A:ALL;E:EXIT",DIR("B")="ALL"
- D ^DIR
- Q:$D(DIRUT)!(Y="E")
- S PSOCSRT=$S(Y="A":1,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 (Disregards eRx Pending orders)
- .I PSRT<4,'$$ERXIEN^PSOERXUT(PSOD_"P"),'$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,'$$ERXIEN^PSOERXUT(ORD_"P"),'$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
- ;*545 - show DEA label only, get the stored DEA#
- S:$L($G(PSORX("RXDEA"))) DEA=PSORX("RXDEA")
- ;If renew, try to get DEA from the renewal from CPRS rather than the original RX, provider may have changed
- I $G(PSOORRNW),$G(ORN) S DEA=$$RXDEA^PSOUTIL(,ORN)
- 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
- S:$L($G(PSORX("DETX"))) DETN=PSORX("DETX")
- S LBL="DEA#: " I $G(ADDS) S LBL=" "_LBL
- I DRG,$$DETOX^PSSOPKI(DRG),'$L($G(DETN)) 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOORFI5 10722 printed Feb 18, 2025@23:58:28 Page 2
- 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
- +2 ;External references UL^PSSLOCK supported by DBIA 2789
- +3 ;External reference to ^DPT supported by DBIA 10035
- +4 ;External reference to ^PSSUTLA1 supported by DBIA 3373
- +5 ;
- FLG WRITE !
- KILL MEDP,MEDA,POERR("DFLG"),DIR
- DO KQ
- SET PSOSORT="FLAGGED^FLAGGED"
- +1 NEW SECSORT
- SET SECSORT=$$DIR^PSOORFI6("FL:FLAGGED","FLAGGED")
- if SECSORT=U
- QUIT
- +2 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
- +3 if '$DATA(^PS(52.41,PSOD,0))!('$PIECE($GET(^PS(52.41,PSOD,0)),"^",23))
- QUIT
- +4 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)
- +5 IF PAT'=PATA
- KILL PSORX("DOSING OFF")
- IF $ORDER(PSORX("PSOL",0))!($DATA(RXRS))
- DO LBL^PSOORFIN
- +6 DO LK
- IF $GET(POERR("QFLG"))
- KILL POERR("QFLG")
- SET PSOLK=1
- SET PAT(PAT)=PAT
- QUIT
- +7 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
- +8 SET (PSODFN,Y)=PAT_"^"_$PIECE($GET(^DPT(PAT,0)),"^")
- SET PATA=PAT
- +9 IF SECSORT'=0
- IF '$$CHKFLTR^PSOORFI6(PSOD,SECSORT)
- QUIT
- +10 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
- +11 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
- +12 SET PAT(PAT)=PAT
- +13 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
- +14 IF SECSORT'=0
- IF '$$CHKFLTR^PSOORFI6(ORD,SECSORT)
- QUIT
- +15 IF $PIECE($GET(^PS(52.41,ORD,0)),"^",23)
- DO PP
- DO LK1
- DO ORD^PSOORFIN
- End DoDot:2
- +16 SET X=PAT
- DO ULP
- KILL PSOQQ
- End DoDot:1
- +17 IF $ORDER(PSORX("PSOL",0))!($DATA(RXRS))
- DO LBL^PSOORFIN
- +18 IF $GET(PSOQUIT)
- KILL PSOQUIT
- DO EX
- GOTO ^PSOORFIN
- +19 GOTO EX
- +20 ;
- SUP WRITE !
- KILL MEDP,MEDA,POERR("DFLG"),DIR
- DO KQ
- SET PSOSORT="SUPPLY^SUPPLY"
- +1 NEW SECSORT
- SET SECSORT=$$DIR^PSOORFI6("SU:SUPPLY","SUPPLY")
- if SECSORT=U
- QUIT
- +2 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
- +3 if '$DATA(^PS(52.41,PSOD,0))!('$$ISSUPPLY^PSOORFI6(PSOD))
- QUIT
- +4 IF SECSORT'=0
- IF '$$CHKFLTR^PSOORFI6(PSOD,SECSORT)
- QUIT
- +5 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)
- +6 IF PAT'=PATA
- KILL PSORX("DOSING OFF")
- IF $ORDER(PSORX("PSOL",0))!($DATA(RXRS))
- DO LBL^PSOORFIN
- +7 DO LK
- IF $GET(POERR("QFLG"))
- KILL POERR("QFLG")
- SET PSOLK=1
- SET PAT(PAT)=PAT
- QUIT
- +8 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
- +9 SET (PSODFN,Y)=PAT_"^"_$PIECE($GET(^DPT(PAT,0)),"^")
- SET PATA=PAT
- +10 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
- +11 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
- +12 SET PAT(PAT)=PAT
- +13 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
- +14 IF $PIECE($GET(^PS(52.41,ORD,0)),"^",23)
- IF $PIECE(SECSORT,"^",1)'="FL"
- QUIT
- +15 if '$$ISSUPPLY^PSOORFI6(ORD)
- QUIT
- +16 IF SECSORT'=0
- IF '$$CHKFLTR^PSOORFI6(ORD,SECSORT)
- QUIT
- +17 DO PP
- DO LK1
- DO ORD^PSOORFIN
- End DoDot:2
- +18 SET X=PAT
- DO ULP
- KILL PSOQQ
- End DoDot:1
- +19 IF $ORDER(PSORX("PSOL",0))!($DATA(RXRS))
- DO LBL^PSOORFIN
- +20 IF $GET(PSOQUIT)
- KILL PSOQUIT
- DO EX
- GOTO ^PSOORFIN
- +21 GOTO EX
- +22 QUIT
- 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 NEW SECSORT
- SET SECSORT=$$DIR^PSOORFI6("PR:PRIORITY",Y)
- if SECSORT=U
- QUIT
- +5 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
- +6 IF $PIECE($GET(^PS(52.41,PSOD,0)),"^",23)
- IF $PIECE(SECSORT,"^",1)'="FL"
- QUIT
- +7 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)
- +8 ;PSO*7*266
- +9 IF PAT'=PATA
- KILL PSORX("DOSING OFF")
- DO LBL^PSOORFIN
- +10 IF '$ORDER(^PS(52.41,"AP",PAT,PSRT,0))
- SET PSOLK=1
- SET PAT(PAT)=PAT
- QUIT
- +11 DO PRI^PSOORFI2
- IF $GET(PSZFIN)
- SET PSOLK=1
- SET PAT(PAT)=PAT
- QUIT
- +12 DO LK
- IF $GET(POERR("QFLG"))
- KILL POERR("QFLG")
- SET PSOLK=1
- SET PAT(PAT)=PAT
- QUIT
- +13 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
- +14 SET (PSODFN,Y)=PAT_"^"_$PIECE($GET(^DPT(PAT,0)),"^")
- SET PATA=PAT
- +15 IF SECSORT'=0
- IF '$$CHKFLTR^PSOORFI6(PSOD,SECSORT)
- QUIT
- +16 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
- +17 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
- +18 DO PP
- SET ORD=0
- DO @PSRT
- SET PAT(PAT)=PAT
- +19 SET X=PAT
- DO ULP
- End DoDot:1
- +20 ;PSO*7*266
- +21 DO LBL^PSOORFIN
- +22 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 Information
- +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
- +18 ;
- CS ; Digitally Signed CS - PSO*7*391
- +1 KILL DIR
- +2 NEW PSOCSRT,PSOPARKX,RESULTS,Y
- +3 SET DIR("A")="Route"
- SET DIR(0)="SBM^W:WINDOW;M:MAIL;B:BOTH;E:EXIT"
- SET DIR("B")="BOTH"
- +4 SET RESULTS="PSOPARKX"
- DO GETPARK^PSORPC01()
- +5 IF $GET(PSOPARKX(0))="YES"
- SET DIR(0)="SBM^W:WINDOW;M:MAIL;P:PARK;A:ALL;E:EXIT"
- SET DIR("B")="ALL"
- +6 DO ^DIR
- +7 if $DATA(DIRUT)!(Y="E")
- QUIT
- +8 SET PSOCSRT=$SELECT(Y="A":1,Y="B":1,1:Y)
- +9 WRITE !!,"Select a schedule(s)"
- +10 KILL DIR
- SET PSOSORT="DIGITALLY SIGNED"
- +11 SET DIR("A")="Select Schedule(s)"
- SET 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"
- SET DIR("B")=3
- +12 DO ^DIR
- if $DATA(DIRUT)!(Y="E")
- GOTO EX
- SET PSOSORT=PSOSORT_"^"_Y
- SET PSRT=Y
- +13 NEW SECSORT
- SET SECSORT=$$DIR^PSOORFI6("CS:CONTROLLED SUBSTANCES",Y)
- if SECSORT=U
- QUIT
- +14 NEW PDEA,OR0
- 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
- +15 if '$DATA(^PS(52.41,PSOD,0))
- QUIT
- +16 SET OR0=^PS(52.41,PSOD,0)
- +17 ;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
- +18 IF $PIECE(OR0,"^",23)
- IF $PIECE(SECSORT,"^",1)'="FL"
- QUIT
- +19 SET PDEA=0
- DO PDEA
- if 'PDEA!(PDEA'=PSRT)
- QUIT
- +20 ;PSO*7*505 moved digitally signed check after the DEA check (Disregards eRx Pending orders)
- +21 IF PSRT<4
- IF '$$ERXIEN^PSOERXUT(PSOD_"P")
- IF '$PIECE(OR0,"^",24)
- QUIT
- +22 IF 'PSOCSRT
- IF PSOCSRT'=$PIECE(OR0,"^",17)
- QUIT
- +23 if $GET(PAT($PIECE(OR0,"^",2)))=$PIECE(OR0,"^",2)
- QUIT
- SET PAT=$PIECE(OR0,"^",2)
- +24 IF PAT'=PATA
- KILL PSORX("DOSING OFF")
- IF $ORDER(PSORX("PSOL",0))!($DATA(RXRS))
- DO LBL^PSOORFIN
- +25 DO LK
- IF $GET(POERR("QFLG"))
- KILL POERR("QFLG")
- SET PSOLK=1
- SET PAT(PAT)=PAT
- QUIT
- +26 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
- +27 SET (PSODFN,Y)=PAT_"^"_$PIECE($GET(^DPT(PAT,0)),"^")
- SET PATA=PAT
- +28 IF SECSORT'=0
- IF '$$CHKFLTR^PSOORFI6(PSOD,SECSORT)
- QUIT
- +29 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
- +30 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
- +31 SET PAT(PAT)=PAT
- +32 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
- +33 if '$DATA(^PS(52.41,ORD,0))
- QUIT
- +34 SET OR0=^PS(52.41,ORD,0)
- +35 ;PSO*505 - Move the check for digitally signed, so non-cs substances will be shown if selected as sort criteria
- +36 IF $PIECE(OR0,U,23)
- IF $PIECE(SECSORT,"^",1)'="FL"
- QUIT
- +37 IF SECSORT'=0
- IF '$$CHKFLTR^PSOORFI6(ORD,SECSORT)
- QUIT
- +38 IF 'PSOCSRT
- IF PSOCSRT'=$PIECE(OR0,"^",17)
- QUIT
- +39 if $PIECE(OR0,"^",3)="DC"!($PIECE(OR0,"^",3)="DE")
- QUIT
- +40 SET PDEA=0
- DO PDEA
- if 'PDEA!(PDEA'=PSRT)
- QUIT
- +41 IF PSRT<4
- IF '$$ERXIEN^PSOERXUT(ORD_"P")
- IF '$PIECE(OR0,"^",24)
- QUIT
- +42 DO PP
- DO LK1
- DO ORD^PSOORFIN
- End DoDot:2
- +43 SET X=PAT
- DO ULP
- KILL PSOQQ
- End DoDot:1
- +44 IF $ORDER(PSORX("PSOL",0))!($DATA(RXRS))
- DO LBL^PSOORFIN
- +45 IF $GET(PSOQUIT)
- KILL PSOQUIT
- DO EX
- GOTO ^PSOORFIN
- +46 GOTO EX
- +47 ;
- PDEA ;
- +1 IF +$PIECE(OR0,"^",9)
- SET PDEA=$PIECE($GET(^PSDRUG($PIECE(OR0,"^",9),0)),"^",3)
- SET PDEA=$SELECT(PDEA[2:1,PDEA[3!(PDEA[4)!(PDEA[5):2,1:0)
- +2 IF '$TEST
- SET PDEA=$$OIDEA^PSSUTLA1($PIECE(OR0,"^",8),"O")
- +3 ; PSO*7*505 - adding checks for new sort criteria
- +4 ; PDEA=0 OR 2, covers non-cs and schedule 3-5
- +5 IF (PDEA=0)!(PDEA=2)
- IF PSRT=4
- SET PDEA=4
- QUIT
- +6 IF PDEA=0
- IF PSRT=5
- SET PDEA=5
- QUIT
- +7 ; PSO*7*505 end
- +8 IF PDEA
- IF PSRT=3
- SET PDEA=3
- +9 QUIT
- +10 ;
- PRV(PROV,DRG,ORN) ;
- +1 NEW DETN,DEA,I,LBL,VADD,SPC
- +2 IF PROV=""
- QUIT
- +3 ;*545 - show DEA label only, get the stored DEA#
- +4 if $LENGTH($GET(PSORX("RXDEA")))
- SET DEA=PSORX("RXDEA")
- +5 ;If renew, try to get DEA from the renewal from CPRS rather than the original RX, provider may have changed
- +6 IF $GET(PSOORRNW)
- IF $GET(ORN)
- SET DEA=$$RXDEA^PSOUTIL(,ORN)
- +7 IF '$LENGTH($GET(DEA))
- SET DEA=$SELECT($GET(PSONEW("OIRXN")):$$RXDEA^PSOUTIL(PSONEW("OIRXN")),$GET(ORN):$$RXDEA^PSOUTIL(,ORN),1:$$DEA^XUSER(0,PROV))
- if DEA]""
- SET PSORX("RXDEA")=DEA
- +8 if $LENGTH($GET(PSORX("DETX")))
- SET DETN=PSORX("DETX")
- +9 SET LBL="DEA#: "
- IF $GET(ADDS)
- SET LBL=" "_LBL
- +10 IF DRG
- IF $$DETOX^PSSOPKI(DRG)
- IF '$LENGTH($GET(DETN))
- SET DETN=$SELECT($GET(ORN):$$RXDETOX^PSOUTIL(,ORN),1:$$DETOX^XUSER(PROV))
- +11 SET $PIECE(SPC," ",($SELECT($GET(ADDS):30,1:33)-$LENGTH(DEA)))=" "
- +12 IF (DEA'="")!($GET(DETN)'="")
- SET IEN=IEN+1
- SET $EXTRACT(^TMP("PSOPO",$JOB,IEN,0),16)=LBL_DEA_$SELECT($GET(DETN)]"":SPC_"DETOX#: "_$GET(DETN),1:"")
- +13 IF $GET(ORN)
- DO PRVAD^PSOPKIV2
- IF $GET(VADD(1))]""
- Begin DoDot:1
- +14 SET IEN=IEN+1
- SET ^TMP("PSOPO",$JOB,IEN,0)=$SELECT($GET(ADDS):" ",1:"")_" Site Address: "_VADD(1)
- +15 if VADD(2)'=""
- SET IEN=IEN+1
- SET ^TMP("PSOPO",$JOB,IEN,0)=$SELECT($GET(ADDS):" ",1:"")_" "_VADD(2)
- if VADD(3)'=""
- SET IEN=IEN+1
- SET ^TMP("PSOPO",$JOB,IEN,0)=$SELECT($GET(ADDS):" ",1:"")_" "_VADD(3)
- End DoDot:1
- +16 QUIT