- PSOHLEXP ;BIR/RTR-Auto expire prescriptions ;29-May-2012 14:50;PLS
- ;;7.0;OUTPATIENT PHARMACY;**10,22,36,73,1004,148,257,1015**;DEC 1997;Build 62
- ;Modified - IHS/CIA/PLS - 10/07/05 - EN+10
- ;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
- 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")=""
- .S PSOEXSTA=$P($G(^PSRX(PSOEXRX,"STA")),"^")
- .;IHS/CIA/PLS - 10/07/05 - Added exit logic for non-verified prescriptions so that they will not auto-expire
- .Q:PSOEXSTA=1
- .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
- PSOHLEXP ;BIR/RTR-Auto expire prescriptions ;29-May-2012 14:50;PLS
- +1 ;;7.0;OUTPATIENT PHARMACY;**10,22,36,73,1004,148,257,1015**;DEC 1997;Build 62
- +2 ;Modified - IHS/CIA/PLS - 10/07/05 - EN+10
- +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 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 SET PSOEXSTA=$PIECE($GET(^PSRX(PSOEXRX,"STA")),"^")
- +12 ;IHS/CIA/PLS - 10/07/05 - Added exit logic for non-verified prescriptions so that they will not auto-expire
- +13 IF PSOEXSTA=1
- QUIT
- +14 IF PSOEXSTA=13
- Begin DoDot:2
- +15 IF 'ORN
- DO EN^PSOHDR("PRES",PSOEXRX)
- End DoDot:2
- QUIT
- +16 IF PSOEXSTA=12!(PSOEXSTA=14)!(PSOEXSTA=15)
- IF ORN
- IF CPRSDC'[(","_CPRSSTA_",")
- Begin DoDot:2
- +17 DO EN^PSOHLSN1(PSOEXRX,"OD","","","A")
- +18 IF ORN
- SET CPRSSTA=+$$STATUS^ORQOR2(ORN)
- End DoDot:2
- +19 IF PSOEXSTA=11
- IF ORN
- IF CPRSDC'[(","_CPRSSTA_",")
- Begin DoDot:2
- +20 SET $PIECE(^PSRX(PSOEXRX,0),"^",19)=1
- +21 DO EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription is expired")
- End DoDot:2
- +22 IF PSOEXSTA>9&(PSOEXSTA'=16)
- QUIT
- +23 SET $PIECE(^PSRX(PSOEXRX,"STA"),"^")=11
- +24 DO REVERSE^PSOBPSU1(PSOEXRX,0,"DE",5,"RX EXPIRED")
- +25 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)),"^")
- +26 SET ORN=$PIECE($GET(^PSRX(PSOEXRX,"OR1")),"^",2)
- +27 IF $GET(PSUSD)
- IF '$PIECE($GET(^PSRX(PSOEXRX,1,PSUSD,0)),"^",18)
- SET PSDTEST=0
- Begin DoDot:2
- +28 DO REVERSE^PSOBPSU1(PSOEXRX,PSUSD,"DE",5,"RX EXPIRED")
- +29 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
- +30 IF $GET(CMOP(CMOP("L")))=""
- IF ".L.X."[("."_$GET(CMOP("S"))_".")
- SET PSDTEST=1
- +31 NEW PSOORL
- +32 SET PSOORL=$$LOCK1^ORX2(ORN)
- IF 'PSOORL
- SET PSDTEST=1
- IF PSOORL
- DO UNLK1^ORX2(ORN)
- +33 NEW PDA0
- +34 ;S PDAQ=0
- +35 FOR PDA=0:0
- SET PDA=$ORDER(^PSRX(PSOEXRX,4,PDA))
- IF 'PDA
- QUIT
- Begin DoDot:3
- +36 SET PDA0=$GET(^PSRX(PSOEXRX,4,PDA,0))
- +37 ;*257
- IF $PIECE(PDA0,"^",3)=PSUSD
- SET PSDTEST=1
- End DoDot:3
- +38 ;Q:'PDAQ
- +39 ;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
- +40 IF 'ORN
- DO EN^PSOHDR("PRES",PSOEXRX)
- QUIT
- +41 IF CPRSDC[(","_CPRSSTA_",")
- DO EN^PSOHDR("PRES",PSOEXRX)
- QUIT
- +42 SET $PIECE(^PSRX(PSOEXRX,0),"^",19)=1
- +43 SET PSOEXCOM="Prescription past expiration date"
- DO EN^PSOHLSN1(PSOEXRX,"SC","ZE",PSOEXCOM)
- End DoDot:1
- +44 SET DIE=59.7
- SET DA=1
- SET DR="49.95///"_ZZDT
- DO ^DIE
- KILL DIE,DA,DR
- +45 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
