PSOHLEXP ;BIR/RTR - Auto expire prescriptions ;Oct 20, 2022@13:36
;;7.0;OUTPATIENT PHARMACY;**10,22,36,73,148,257,391,505,441,545**;DEC 1997;Build 270
;
;External reference to ^PS(59.7 supported by DBIA 694
;External reference to STATUS^ORQOR2 is supported by DBIA 3458
;External references to LOCK1^ORX2 and UNLK1^ORX2 are supported by DBIA 867
EN N PSOEXRX,PSOEXCOM,PSOEXSTS,SUSD,PSOEXSTA,ZZDT,ZZEDT,IFN,NODE,RF,PIFN,PSUSD,PRFDT,PDA,PSDTEST,ORN,CPRSDC
I '$G(DT) S DT=$$DT^XLFDT
S X1=DT,X2=-1 D C^%DTC S ZZEDT=X
S ZZDT=$P($G(^PS(59.7,1,49.99)),"^",8) I +ZZDT=0 S X1=DT,X2=-2 D C^%DTC S ZZDT=X
F S ZZDT=$O(^PSRX("AG",ZZDT)) Q:ZZDT>ZZEDT Q:ZZDT="" D EN1
D FACDEA
Q
EN1 F PSOEXRX=0:0 S PSOEXRX=$O(^PSRX("AG",ZZDT,PSOEXRX)) Q:'PSOEXRX D:$D(^PSRX(PSOEXRX,0))
.N CPRSDC,CPRSSTA
.S CPRSDC=",1,7,12,13,"
.S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2),CPRSSTA=""
.I ORN S CPRSSTA=+$$STATUS^ORQOR2(ORN) I CPRSSTA=0 S ORN=""
.Q:$P($G(^PSRX(PSOEXRX,2)),"^",6)'=ZZDT
.K CMOP S DA=PSOEXRX I DA D ^PSOCMOPA ;*257 ;SET UP CMOP() ARRAY
.S DA=$O(^PS(52.5,"B",PSOEXRX,0))
.I DA S SUSD=$P($G(^PS(52.5,DA,0)),"^",2) I SUSD,$P($G(^(0)),"^",3) S DIK="^PS(52.5," D ^DIK K DIK
.I $D(^PS(52.4,PSOEXRX,0)) S DIK="^PS(52.4,",DA=PSOEXRX D ^DIK K DIK
.I $G(^PSRX(PSOEXRX,"H"))]"" K:$P(^PSRX(PSOEXRX,"H"),"^") ^PSRX("AH",$P(^PSRX(PSOEXRX,"H"),"^"),PSOEXRX) S ^PSRX(PSOEXRX,"H")=""
.I $G(^PSRX(PSOEXRX,"PARK")) K ^PSRX(PSOEXRX,"PARK"),^PSRX("APARK",1,PSOEXRX) ;*441
.S PSOEXSTA=$P($G(^PSRX(PSOEXRX,"STA")),"^")
.I PSOEXSTA=13 D Q
..I 'ORN D EN^PSOHDR("PRES",PSOEXRX)
.I PSOEXSTA=12!(PSOEXSTA=14)!(PSOEXSTA=15) I ORN,CPRSDC'[(","_CPRSSTA_",") D
..D EN^PSOHLSN1(PSOEXRX,"OD","","","A")
..I ORN S CPRSSTA=+$$STATUS^ORQOR2(ORN)
.I PSOEXSTA=11 I ORN,CPRSDC'[(","_CPRSSTA_",") D
..S $P(^PSRX(PSOEXRX,0),"^",19)=1
..D EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription is expired")
.I PSOEXSTA>9&(PSOEXSTA'=16) Q
.S $P(^PSRX(PSOEXRX,"STA"),"^")=11
.D REVERSE^PSOBPSU1(PSOEXRX,0,"DE",5,"RX EXPIRED")
.S (PIFN,PSUSD,PRFDT)=0 F S PIFN=$O(^PSRX(PSOEXRX,1,PIFN)) Q:'PIFN S PSUSD=PIFN,PRFDT=+$P($G(^PSRX(PSOEXRX,1,PIFN,0)),"^")
.S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2)
.I $G(PSUSD) I '$P($G(^PSRX(PSOEXRX,1,PSUSD,0)),"^",18) S PSDTEST=0 D I 'PSDTEST K ^PSRX(PSOEXRX,1,PSUSD),^PSRX("AD",PRFDT,PSOEXRX,PSUSD),^PSRX(PSOEXRX,1,"B",PRFDT,PSUSD) D NSET
..D REVERSE^PSOBPSU1(PSOEXRX,PSUSD,"DE",5,"RX EXPIRED")
..F PDA=0:0 S PDA=$O(^PSRX(PSOEXRX,"L",PDA)) Q:'PDA I $P($G(^PSRX(PSOEXRX,"L",PDA,0)),"^",2)=PSUSD S PSDTEST=1
..I $G(CMOP(CMOP("L")))="",".L.X."[("."_$G(CMOP("S"))_".") S PSDTEST=1
..N PSOORL
..S PSOORL=$$LOCK1^ORX2(ORN) S:'PSOORL PSDTEST=1 I PSOORL D UNLK1^ORX2(ORN)
..N PDA0
..;S PDAQ=0
..F PDA=0:0 S PDA=$O(^PSRX(PSOEXRX,4,PDA)) Q:'PDA D
...S PDA0=$G(^PSRX(PSOEXRX,4,PDA,0))
...I $P(PDA0,"^",3)=PSUSD S PSDTEST=1 ;*257
..;Q:'PDAQ
..;S PSDTEST=1
.I 'ORN D EN^PSOHDR("PRES",PSOEXRX) Q
.I CPRSDC[(","_CPRSSTA_",") D EN^PSOHDR("PRES",PSOEXRX) Q
.S $P(^PSRX(PSOEXRX,0),"^",19)=1
.S PSOEXCOM="Prescription past expiration date" D EN^PSOHLSN1(PSOEXRX,"SC","ZE",PSOEXCOM)
S DIE=59.7,DA=1,DR="49.95///"_ZZDT D ^DIE K DIE,DA,DR
Q
NSET ;
N PSONM,PSONMX
S PSONM="" F PSONMX=0:0 S PSONMX=$O(^PSRX(PSOEXRX,1,PSONMX)) Q:'PSONMX S PSONM=PSONMX
S ^PSRX(PSOEXRX,1,0)="^52.1DA^"_$G(PSONM)_"^"_$G(PSONM)
Q
SETUP ;
K %DT,DIC,DTOUT S DIC(0)="XZM",DIC="^DIC(19.2,",X="PSO EXPIRE PRESCRIPTIONS" D ^DIC
I +Y>0 D EDIT^XUTMOPT("PSO EXPIRE PRESCRIPTIONS") K DIC,Y,X Q
D RESCH^XUTMOPT("PSO EXPIRE PRESCRIPTIONS","","","24H","L"),EDIT^XUTMOPT("PSO EXPIRE PRESCRIPTIONS") K DIC,Y,X
OUT Q
FACDEA ;PSO*7*391/JAM - Checks and notifies PSDMGR group when facility DEA is about to expire. /BLB/ PSO*7.0*505 ;MODIFIED THE TEXT OF THE MESSAGE
N DIV,INACT,SITE,DEA,DEAXDT,XMDUZ,XMY,XMTEXT,XMSUB,USR,TEXT
S DIV=0 F S DIV=$O(^PS(59,DIV)) Q:'DIV D
.S INACT=$P($G(^PS(59,DIV,"I")),"^") I INACT,DT>INACT Q
.S SITE=$P($G(^PS(59,DIV,"INI")),"^") I SITE="" Q
.I '$$ACTIVE^XUAF4(SITE) Q
.S DEA=$$WHAT^XUAF4(SITE,52) I DEA="" Q
.S DEAXDT=$$GET1^DIQ(4,SITE,52.1,"I") I '+DEAXDT Q
.I $$FMDIFF^XLFDT(DEAXDT,DT)>30 Q
.S DIV(SITE)=DEA_"^"_DEAXDT
S SITE=0 F S SITE=$O(DIV(SITE)) Q:'SITE D
.K TEXT
.S DEAXDT=$P(DIV(SITE),"^",2)
.S TEXT(1)=""
.S TEXT(2)="The institutional (facility) DEA Number for"
.S TEXT(3)=$$GET1^DIQ(4,SITE,.01,"I")_" (Institution File #4 IEN = "_SITE_")"
.S TEXT(4)=$S($$FMDIFF^XLFDT(DEAXDT,DT)<0:"expired on ",1:"is about to expire on ")_$$GET1^DIQ(4,SITE,52.1,"E")
.S TEXT(5)=""
.S TEXT(6)="Please update the Institutional DEA expiration date using option "
.S TEXT(7)="Edit Facility DEA# and Expiration Date [PSO EPCS EDIT DEA# AND XDATE]. "
.S XMTEXT="TEXT(",XMSUB="Institutional DEA Number "_$S($$FMDIFF^XLFDT(DEAXDT,DT)<0:"has expired",1:"is about to expire"),XMDUZ=.5
.S USR="" F S USR=$O(^XUSEC("PSDMGR",USR)) Q:USR="" S XMY(USR)=""
.D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHLEXP 4967 printed Dec 13, 2024@02:29:53 Page 2
PSOHLEXP ;BIR/RTR - Auto expire prescriptions ;Oct 20, 2022@13:36
+1 ;;7.0;OUTPATIENT PHARMACY;**10,22,36,73,148,257,391,505,441,545**;DEC 1997;Build 270
+2 ;
+3 ;External reference to ^PS(59.7 supported by DBIA 694
+4 ;External reference to STATUS^ORQOR2 is supported by DBIA 3458
+5 ;External references to LOCK1^ORX2 and UNLK1^ORX2 are supported by DBIA 867
EN NEW PSOEXRX,PSOEXCOM,PSOEXSTS,SUSD,PSOEXSTA,ZZDT,ZZEDT,IFN,NODE,RF,PIFN,PSUSD,PRFDT,PDA,PSDTEST,ORN,CPRSDC
+1 IF '$GET(DT)
SET DT=$$DT^XLFDT
+2 SET X1=DT
SET X2=-1
DO C^%DTC
SET ZZEDT=X
+3 SET ZZDT=$PIECE($GET(^PS(59.7,1,49.99)),"^",8)
IF +ZZDT=0
SET X1=DT
SET X2=-2
DO C^%DTC
SET ZZDT=X
+4 FOR
SET ZZDT=$ORDER(^PSRX("AG",ZZDT))
if ZZDT>ZZEDT
QUIT
if ZZDT=""
QUIT
DO EN1
+5 DO FACDEA
+6 QUIT
EN1 FOR PSOEXRX=0:0
SET PSOEXRX=$ORDER(^PSRX("AG",ZZDT,PSOEXRX))
if 'PSOEXRX
QUIT
if $DATA(^PSRX(PSOEXRX,0))
Begin DoDot:1
+1 NEW CPRSDC,CPRSSTA
+2 SET CPRSDC=",1,7,12,13,"
+3 SET ORN=$PIECE($GET(^PSRX(PSOEXRX,"OR1")),"^",2)
SET CPRSSTA=""
+4 IF ORN
SET CPRSSTA=+$$STATUS^ORQOR2(ORN)
IF CPRSSTA=0
SET ORN=""
+5 if $PIECE($GET(^PSRX(PSOEXRX,2)),"^",6)'=ZZDT
QUIT
+6 ;*257 ;SET UP CMOP() ARRAY
KILL CMOP
SET DA=PSOEXRX
IF DA
DO ^PSOCMOPA
+7 SET DA=$ORDER(^PS(52.5,"B",PSOEXRX,0))
+8 IF DA
SET SUSD=$PIECE($GET(^PS(52.5,DA,0)),"^",2)
IF SUSD
IF $PIECE($GET(^(0)),"^",3)
SET DIK="^PS(52.5,"
DO ^DIK
KILL DIK
+9 IF $DATA(^PS(52.4,PSOEXRX,0))
SET DIK="^PS(52.4,"
SET DA=PSOEXRX
DO ^DIK
KILL DIK
+10 IF $GET(^PSRX(PSOEXRX,"H"))]""
if $PIECE(^PSRX(PSOEXRX,"H"),"^")
KILL ^PSRX("AH",$PIECE(^PSRX(PSOEXRX,"H"),"^"),PSOEXRX)
SET ^PSRX(PSOEXRX,"H")=""
+11 ;*441
IF $GET(^PSRX(PSOEXRX,"PARK"))
KILL ^PSRX(PSOEXRX,"PARK"),^PSRX("APARK",1,PSOEXRX)
+12 SET PSOEXSTA=$PIECE($GET(^PSRX(PSOEXRX,"STA")),"^")
+13 IF PSOEXSTA=13
Begin DoDot:2
+14 IF 'ORN
DO EN^PSOHDR("PRES",PSOEXRX)
End DoDot:2
QUIT
+15 IF PSOEXSTA=12!(PSOEXSTA=14)!(PSOEXSTA=15)
IF ORN
IF CPRSDC'[(","_CPRSSTA_",")
Begin DoDot:2
+16 DO EN^PSOHLSN1(PSOEXRX,"OD","","","A")
+17 IF ORN
SET CPRSSTA=+$$STATUS^ORQOR2(ORN)
End DoDot:2
+18 IF PSOEXSTA=11
IF ORN
IF CPRSDC'[(","_CPRSSTA_",")
Begin DoDot:2
+19 SET $PIECE(^PSRX(PSOEXRX,0),"^",19)=1
+20 DO EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription is expired")
End DoDot:2
+21 IF PSOEXSTA>9&(PSOEXSTA'=16)
QUIT
+22 SET $PIECE(^PSRX(PSOEXRX,"STA"),"^")=11
+23 DO REVERSE^PSOBPSU1(PSOEXRX,0,"DE",5,"RX EXPIRED")
+24 SET (PIFN,PSUSD,PRFDT)=0
FOR
SET PIFN=$ORDER(^PSRX(PSOEXRX,1,PIFN))
if 'PIFN
QUIT
SET PSUSD=PIFN
SET PRFDT=+$PIECE($GET(^PSRX(PSOEXRX,1,PIFN,0)),"^")
+25 SET ORN=$PIECE($GET(^PSRX(PSOEXRX,"OR1")),"^",2)
+26 IF $GET(PSUSD)
IF '$PIECE($GET(^PSRX(PSOEXRX,1,PSUSD,0)),"^",18)
SET PSDTEST=0
Begin DoDot:2
+27 DO REVERSE^PSOBPSU1(PSOEXRX,PSUSD,"DE",5,"RX EXPIRED")
+28 FOR PDA=0:0
SET PDA=$ORDER(^PSRX(PSOEXRX,"L",PDA))
if 'PDA
QUIT
IF $PIECE($GET(^PSRX(PSOEXRX,"L",PDA,0)),"^",2)=PSUSD
SET PSDTEST=1
+29 IF $GET(CMOP(CMOP("L")))=""
IF ".L.X."[("."_$GET(CMOP("S"))_".")
SET PSDTEST=1
+30 NEW PSOORL
+31 SET PSOORL=$$LOCK1^ORX2(ORN)
if 'PSOORL
SET PSDTEST=1
IF PSOORL
DO UNLK1^ORX2(ORN)
+32 NEW PDA0
+33 ;S PDAQ=0
+34 FOR PDA=0:0
SET PDA=$ORDER(^PSRX(PSOEXRX,4,PDA))
if 'PDA
QUIT
Begin DoDot:3
+35 SET PDA0=$GET(^PSRX(PSOEXRX,4,PDA,0))
+36 ;*257
IF $PIECE(PDA0,"^",3)=PSUSD
SET PSDTEST=1
End DoDot:3
+37 ;Q:'PDAQ
+38 ;S PSDTEST=1
End DoDot:2
IF 'PSDTEST
KILL ^PSRX(PSOEXRX,1,PSUSD),^PSRX("AD",PRFDT,PSOEXRX,PSUSD),^PSRX(PSOEXRX,1,"B",PRFDT,PSUSD)
DO NSET
+39 IF 'ORN
DO EN^PSOHDR("PRES",PSOEXRX)
QUIT
+40 IF CPRSDC[(","_CPRSSTA_",")
DO EN^PSOHDR("PRES",PSOEXRX)
QUIT
+41 SET $PIECE(^PSRX(PSOEXRX,0),"^",19)=1
+42 SET PSOEXCOM="Prescription past expiration date"
DO EN^PSOHLSN1(PSOEXRX,"SC","ZE",PSOEXCOM)
End DoDot:1
+43 SET DIE=59.7
SET DA=1
SET DR="49.95///"_ZZDT
DO ^DIE
KILL DIE,DA,DR
+44 QUIT
NSET ;
+1 NEW PSONM,PSONMX
+2 SET PSONM=""
FOR PSONMX=0:0
SET PSONMX=$ORDER(^PSRX(PSOEXRX,1,PSONMX))
if 'PSONMX
QUIT
SET PSONM=PSONMX
+3 SET ^PSRX(PSOEXRX,1,0)="^52.1DA^"_$GET(PSONM)_"^"_$GET(PSONM)
+4 QUIT
SETUP ;
+1 KILL %DT,DIC,DTOUT
SET DIC(0)="XZM"
SET DIC="^DIC(19.2,"
SET X="PSO EXPIRE PRESCRIPTIONS"
DO ^DIC
+2 IF +Y>0
DO EDIT^XUTMOPT("PSO EXPIRE PRESCRIPTIONS")
KILL DIC,Y,X
QUIT
+3 DO RESCH^XUTMOPT("PSO EXPIRE PRESCRIPTIONS","","","24H","L")
DO EDIT^XUTMOPT("PSO EXPIRE PRESCRIPTIONS")
KILL DIC,Y,X
OUT QUIT
FACDEA ;PSO*7*391/JAM - Checks and notifies PSDMGR group when facility DEA is about to expire. /BLB/ PSO*7.0*505 ;MODIFIED THE TEXT OF THE MESSAGE
+1 NEW DIV,INACT,SITE,DEA,DEAXDT,XMDUZ,XMY,XMTEXT,XMSUB,USR,TEXT
+2 SET DIV=0
FOR
SET DIV=$ORDER(^PS(59,DIV))
if 'DIV
QUIT
Begin DoDot:1
+3 SET INACT=$PIECE($GET(^PS(59,DIV,"I")),"^")
IF INACT
IF DT>INACT
QUIT
+4 SET SITE=$PIECE($GET(^PS(59,DIV,"INI")),"^")
IF SITE=""
QUIT
+5 IF '$$ACTIVE^XUAF4(SITE)
QUIT
+6 SET DEA=$$WHAT^XUAF4(SITE,52)
IF DEA=""
QUIT
+7 SET DEAXDT=$$GET1^DIQ(4,SITE,52.1,"I")
IF '+DEAXDT
QUIT
+8 IF $$FMDIFF^XLFDT(DEAXDT,DT)>30
QUIT
+9 SET DIV(SITE)=DEA_"^"_DEAXDT
End DoDot:1
+10 SET SITE=0
FOR
SET SITE=$ORDER(DIV(SITE))
if 'SITE
QUIT
Begin DoDot:1
+11 KILL TEXT
+12 SET DEAXDT=$PIECE(DIV(SITE),"^",2)
+13 SET TEXT(1)=""
+14 SET TEXT(2)="The institutional (facility) DEA Number for"
+15 SET TEXT(3)=$$GET1^DIQ(4,SITE,.01,"I")_" (Institution File #4 IEN = "_SITE_")"
+16 SET TEXT(4)=$SELECT($$FMDIFF^XLFDT(DEAXDT,DT)<0:"expired on ",1:"is about to expire on ")_$$GET1^DIQ(4,SITE,52.1,"E")
+17 SET TEXT(5)=""
+18 SET TEXT(6)="Please update the Institutional DEA expiration date using option "
+19 SET TEXT(7)="Edit Facility DEA# and Expiration Date [PSO EPCS EDIT DEA# AND XDATE]. "
+20 SET XMTEXT="TEXT("
SET XMSUB="Institutional DEA Number "_$SELECT($$FMDIFF^XLFDT(DEAXDT,DT)<0:"has expired",1:"is about to expire")
SET XMDUZ=.5
+21 SET USR=""
FOR
SET USR=$ORDER(^XUSEC("PSDMGR",USR))
if USR=""
QUIT
SET XMY(USR)=""
+22 DO ^XMD
End DoDot:1
+23 QUIT
