- PSORENW0 ;IHS/DSD/JCM-renew main driver continuation ;2/8/06 8:40am
- ;;7.0;OUTPATIENT PHARMACY;**11,27,32,59,64,46,71,96,100,130,237,206,251,375,379,372,411,518,457,545**;DEC 1997;Build 270
- ;External reference to ^PS(50.7 supported by DBIA 2223
- ;External reference to ^PSDRUG( supported by DBIA 221
- ;External reference to PSOL^PSSLOCK supported by DBIA 2789
- ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
- ;
- ;PSO*237 was not adding to Clozapine Override file, fix
- PROCESS ;
- D ^PSORENW1
- D INST2^PSORENW
- I $D(PSORX("BAR CODE")),PSODFN'=PSORENW("PSODFN") D NEWPT
- S PSORENW("DFLG")=0,PSORENW("FILL DATE")=PSORNW("FILL DATE")
- I $G(PSORNW("MAIL/WINDOW"))]"" S PSORENW("MAIL/WINDOW")=PSORNW("MAIL/WINDOW")
- W !!,"Now Renewing Rx # "_PSORENW("ORX #")_" Drug: "_$$GET1^DIQ(50,+$G(PSORENW("DRUG IEN")),.01),!
- D CHECK G:PSORENW("DFLG") PROCESSX
- D FILDATE
- D DRUG G:PSORENW("DFLG")!PSORX("DFLG") PROCESSX
- D RXN G:PSORENW("DFLG") PROCESSX
- D STOP^PSORENW1,OERR^PSORENW1:$G(PSOFDR)
- DSPL K PSOEDT,PSOLM D DSPLY^PSORENW3 G:PSORENW("DFLG") PROCESSX
- S PSORENW("QFLG")=0 D:'$G(PSOFDR) EDIT
- G:PSORENW("DFLG")!$G(PSORX("FN")) PROCESSX
- G:'$G(PSORX("FN"))&('$G(PSORENW("QFLG"))) DSPL
- D:$$FIND1^DIC(200.051,","_DUZ_",","X","PSORPH")!('$P(PSOPAR,"^",2)) VER1^PSOORNE4(.PSORENW) I PSORENW("DFLG")=1 G PROCESSX
- I $G(NEWDOSE),PSORENW("ENT")>0 K NEWDOSE G DSPL
- D EN^PSORN52(.PSORENW)
- D RNPSOSD^PSOUTIL
- D CAN,DCORD^PSONEW2
- S BBRN1=$$FIND1^DIC(52,,"X",PSORENW("NRX #")) I $$GET1^DIQ(52,BBRN1,11,"I")["W" S BINGCRT="Y",BINGRTE="W"
- ;PSO*237 add to Clozapine Override file
- ANQ I $G(ANQDATA)]"" N PSOUSER,PSO1PH,PSO2PH,PSOREASN,PSOREMRK S PSOUSER=$P(ANQDATA,"^",5),PSO1PH=$P(ANQDATA,"^"),PSO2PH=$P(ANQDATA,"^",5),PSOREASN=$P(ANQDATA,"^",3),PSOREMRK=$P(ANQDATA,"^",4) D NOW^%DTC G:$$FIND1^DIC(52.52,,"X",%) ANQ D
- .;; ** START NCC REMEDIATION ** 457/RTW
- .N PSOUSER,PSO1PH,PSO2PH,PSOREASN,PSOREMRK,PSOPROV
- .S PSOPROV=$P(ANQDATA,"^",2),PSO1PH=$P(ANQDATA,"^"),PSO2PH=$P(ANQDATA,"^",5),PSOREASN=$P(ANQDATA,"^",3),PSOREMRK=$P(ANQDATA,"^",4)
- .S XQA(PSO2PH)="",XQA(PSOPROV)=""
- .I $D(ORO) S PSOPROV=$P(ORO,"^",4)
- .K DD,DO S DIC="^PS(52.52,",DIC(0)="L",DLAYGO=52.52,X=%
- .D FILE^DICN K DIC,DLAYGO,DD,DO,DA,DR
- .N PS52 S (PS52,DA)=+Y,DIE="^PS(52.52,",DR="1////"_PSORENW("IRXN")_";2////"_PSO1PH_";3////"_PSOPROV_";4////"_PSOREASN_";5////"_PSOREMRK_";6////"_PSO2PH
- .D ^DIE K DIE,DA,DR
- .K ANQDATA,X,Y,%,ANQREM
- .D ALERT
- ; ** END NCC REMEDIATION ** 457/RTW
- ;
- PROCESSX N PSORWRIT I PSORENW("DFLG")!$G(PSORX("DFLG")) S PSOBBCLK=1 W:'$G(POERR) !,$C(7),"RENEWED RX DELETED",! S PSOWRIT=1,PSORERR=1 D
- .D:$P($G(PSOLST(+$G(ORN))),"^",2) PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) S POERR("DFLG")=1 D CLEAN^PSOVER1 D
- ..W !! K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to Continue" D ^DIR K DIR,DTOUT,DUOUT S VALMBCK="Q"
- D:$G(PSORENW("OLD FILL DATE"))]"" SUSDATEK^PSOUTIL(.PSORENW)
- K PRC,PHI,PSOQUIT,BBRN,BBRN1,PSORENW,PSODRUG,PSORX("PROVIDER NAME"),PSORX("CLINIC"),PSORX("FN"),PSORX("RXDEA"),PSORX("DETX") ;*545
- K PSOEDT,PSOLM S:$G(PSORENW("FROM"))="" (PSORENW("DFLG"),PSORENW("QFLG"))=0
- D CLEAN^PSOVER1
- Q
- ;
- CHECK ;
- I '$D(PSORX("BAR CODE")),PSORENW("PSODFN")'=PSODFN D G CHECKX
- .W !!,?5,$C(7),"Can't renew Rx # "_$P(PSORENW("RX0"),"^")_", it is not for this patient." S PSORENW("DFLG")=1
- .S:$G(POERR) VALMSG="Can't renew Rx # "_$P(PSORENW("RX0"),"^")_", not for this patient.",VALMBCK="R"
- ;Invalid dosage check
- N PSOOCPRX,PSOOLPF,PSOOLPD,PSONOSIG S PSOOCPRX=PSORENW("OIRXN") D CDOSE
- I PSOOLPF!(PSONOSIG) D G CHECKX
- .S PSORENW("DFLG")=1
- .W !!,$C(7),"Cannot renew Rx # "_$P(PSORENW("RX0"),"^")_$S(PSOOLPF:", invalid dosage of "_$G(PSOOLPD),1:", Missing Sig")
- .S:$G(POERR) VALMSG="Cannot renew Rx # "_$P(PSORENW("RX0"),"^")_$S(PSOOLPF:", invalid Dosage of "_$G(PSOOLPD),1:", Missing Sig") S VALMBCK="R"
- .I '$G(PSORNSPD) W ! K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to Continue" D ^DIR K DIR
- .I $G(PSORNSPD) W !
- ;
- N PSOS S (PSOS,PSOX,PSOY)="" K ACOM,DIR,DIRUT,DIRUT,DUOUT N DRG
- I $G(PSOSD) F S PSOS=$O(PSOSD(PSOS)) Q:PSOS="" F S PSOX=$O(PSOSD(PSOS,PSOX)) Q:PSOX']""!(PSORENW("DFLG")) I PSORENW("OIRXN")=+PSOSD(PSOS,PSOX) S PSOY=PSOSD(PSOS,PSOX) I $TR($P(PSOY,"^",3),"B")]"" D K ACOM,DIR,DIRUT,DIRUT,DUOUT
- . S PSORENW("DFLG")=1
- . W !,$C(7),"Cannot renew Rx # ",$P(PSORENW("RX0"),"^")
- . S PSOREA=$P(PSOY,"^",3),PSOSTAT=+PSORENW("STA")
- . D STATUS^PSOUTIL(PSOREA,PSOSTAT) K PSOREA,PSOSTAT
- .I $G(ACOM)]"" D
- ..S DRG=$$GET1^DIQ(52,PSORENW("OIRXN"),6)
- ..W ! S DIR(0)="Y",DIR("A",1)="Do you want to Discontinue this Pending Order",DIR("A")="for "_DRG,DIR("B")="No"
- ..D ^DIR I 'Y!($D(DIRUT)) Q
- ..D NOOR^PSOCAN4 Q:$D(DIRUT) D DE^PSOORFI2
- .Q
- I PSOY="",'$G(PSOORRNW) D
- .W !,$C(7),"Cannot renew Rx # ",$P(PSORENW("RX0"),"^")," later Rx exists." S PSORENW("DFLG")=1
- .S:$G(POERR) VALMSG="Cannot renew Rx # "_$P(PSORENW("RX0"),"^")_" later Rx exists.",VALMBCK="R"
- K PSOX,PSOY G:PSORENW("DFLG") CHECKX
- ;
- I $A($E(PSORENW("ORX #"),$L(PSORENW("ORX #"))))'<90 D Q
- . W !,$C(7),"Cannot renew Rx # "_PSORENW("ORX #")_", Max number of renewals reached."
- .S:$G(POERR)!('$G(SPEED)) (ACOM,VALMSG)="Cannot renew Rx # "_PSORENW("ORX #")_", Max number reached.",VALMBCK="R"
- . S PSORENW("DFLG")=1
- .I $G(OR0)]"" D
- ..S DRG=$$GET1^DIQ(52,PSORENW("OIRXN"),6)
- ..W ! S DIR(0)="Y",DIR("A",1)="Do you want to Discontinue this Pending Order",DIR("A")="for "_DRG,DIR("B")="No"
- ..D ^DIR I 'Y!($D(DIRUT)) Q
- ..D NOOR^PSOCAN4 Q:$D(DIRUT) D DE^PSOORFI2
- .K ACOM Q
- D CHKDIV G:PSORENW("DFLG") CHECKX
- ;
- D CHKPRV^PSOUTIL
- CHECKX Q
- ;
- CHKDIV ;
- G:$P(PSORENW("RX2"),"^",9)=+PSOSITE CHKDIVX
- W !?5,$C(7),"RX # ",$P(PSORENW("RX0"),"^")," is for (",$$GET1^DIQ(59,$P(PSORENW("RX2"),"^",9),.01),") division."
- I '$P($G(PSOSYS),"^",2) S PSORENW("DFLG")=1 G CHKDIVX
- D:$P($G(PSOSYS),"^",3) DIR
- CHKDIVX Q
- ;
- DRUG ;
- K PSOY
- S PSOY=PSORENW("DRUG IEN"),PSOY(0)=^PSDRUG(PSOY,0),PSORENWD=1
- I '$P($G(^PSDRUG(PSOY,2)),"^") D Q:$G(PSORX("DFLG"))
- .I $$GET1^DIQ(52,PSORENW("OIRXN"),39.2,"I") S PSODRUG("OI")=$$GET1^DIQ(52,PSORENW("OIRXN"),39.2,"I"),PSODRUG("OIN")=$$GET1^DIQ(52,PSORENW("OIRXN"),39.2) Q
- .W !!,"Cannot Renew!! No Pharmacy Orderable Item!" S VALMSG="Cannot Renew!! No Pharmacy Orderable Item!",PSORX("DFLG")=1
- D SET^PSODRG
- D POST^PSODRG D:'PSORX("DFLG") DOSCK^PSODOSUT("R") S:$G(PSORX("DFLG")) PSORENW("DFLG")=1 ;remove order checks for v7. do allergy checks only
- S PSONOOR=PSORENW("NOO")
- K PSORX("INTERVENE")
- S:$D(PSONEW("STATUS")) PSORENW("STATUS")=PSONEW("STATUS")
- K PSOY,PSONEW("STATUS"),PSORENWD
- Q
- ;
- RXN ;
- K PSOX
- S PSOX=$E(PSORENW("ORX #"),$L(PSORENW("ORX #")))
- S PSORENW("NRX #")=$S(PSOX?1N:PSORENW("ORX #")_"A",1:$E(PSORENW("ORX #"),1,$L(PSORENW("ORX #"))-1)_$C($A(PSOX)+1))
- RETRY I $O(^PSRX("B",PSORENW("NRX #"),0)) D G:'$G(PSORENW("DFLG")) RETRY
- .W:$A($E(PSORENW("NRX #"),$L(PSORENW("ORX #"))))'=90 !,"Rx # "_PSORENW("NRX #")_" is already on file."
- .S:$G(PSOFDR) VALMSG="Rx # "_PSORENW("NRX #")_" is already on file."
- .I $A($E(PSORENW("NRX #"),$L(PSORENW("ORX #"))))=90 D
- ..W !,"Rx # "_PSORENW("NRX #")_" is already on file. Cannot renew Rx #"_PSORENW("ORX #")_".",!,"A new Rx must be entered.",!
- ..S:$G(PSOFDR) VALMSG="Rx # "_PSORENW("NRX #")_" is already on file. Cannot renew Rx #"_PSORENW("ORX #")_". A new Rx must be entered."
- ..K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to Continue" D ^DIR K DIR
- ..S:$G(POERR)!($G(PSOFDR)) VALMSG="Cannot renew Rx # "_PSORENW("ORX #")_", Max number reached.",VALMBCK="R" S PSORENW("DFLG")=1
- .S PSOX=$E(PSORENW("NRX #"),$L(PSORENW("NRX #")))
- .S PSORENW("NRX #")=$S(PSOX?1N:PSORENW("NRX #")_"A",1:$E(PSORENW("NRX #"),1,$L(PSORENW("NRX #"))-1)_$C($A(PSOX)+1))
- RXNX K PSOX
- Q
- ;
- FILDATE ;
- S PSORENW("IRXN")=PSORENW("OIRXN")
- D NEXT^PSOUTIL(.PSORENW)
- I PSORENW("FILL DATE")<$P(PSORENW("RX3"),"^",2) D
- .D RENFDT^PSOUTIL(.PSORENW)
- .I PSORENW("FILL DATE")<DT,PSORENW("FILL DATE")<PSORNW("FILL DATE") S (Y,PSORENW("FILL DATE"))=DT X ^DD("DD") S PSORX("FILL DATE")=Y K Y
- K PSORENW("IRXN")
- Q
- ;
- EDIT ;
- K DIR,X,Y
- S DIR(0)="Y",DIR("B")=$S($G(DUZ("AG"))'="I":"Y",$G(PSEXDT):"Y",1:"N")
- S DIR("A")="Edit renewed Rx ",DIR("?")="Answer YES to edit the renewed Rx, NO not to."
- D ^DIR K DIR S:$D(DIRUT) PSORENW("DFLG")=1
- G:PSORENW("DFLG") EDITX
- K PSOQUIT,PSORX("FN") I Y S PSORNALL=1 D INIT^PSORENW3,EN^PSOORNE4(.PSORENW) K PSORNALL S:$G(PSOQUIT) PSORENW("DFLG")=1 I '$G(PSORX("FN")) D FULL^VALM1 Q
- Q:$G(PSORX("FN"))
- EDITX S PSOEDT=1,VALMBCK="Q" K X,Y,DIRUT,DTOUT,DUOUT S PSORENW("QFLG")=1
- Q
- ;
- DELETE ;
- K DA,DIK
- S DA=$O(^PS(52.5,"B",PSORENW("OIRXN"),0)),DIK="^PS(52.5,"
- D ^DIK K DIK,DIC
- Q
- ;
- CAN ;
- K REA,DA,MSG
- S REA="C",DA=PSORENW("OIRXN")
- S MSG="Renewed"_$S($G(PSOFDR):" from CPRS",1:"")
- S PSCAN(PSORENW("ORX #"))=DA_"^C"
- D CAN^PSOCAN
- K REA,DA,MSG,PSCAN
- Q
- ;
- DIR ;
- S DIR(0)="Y",DIR("A")="CONTINUE ",DIR("B")="N"
- S DIR("?")="Answer YES to Continue, NO to bypass"
- D ^DIR K DIR
- S:$D(DIRUT)!('Y) PSORENW("DFLG")=1
- DIRX K DIRUT,DTOUT,DUOUT,X,Y
- Q
- NEWPT ;
- S PSOQFLG=0 N PSODFN
- S PSODFN=PSORENW("PSODFN")
- D ^PSOPTPST I PSOQFLG S PSORENW("DFLG")=1,PSOQFLG=0 G NEWPTX
- D PROFILE^PSOREF1
- NEWPTX Q
- ;
- EN(PSORENW) ; Entry Point for Batch Barcode Option
- S PSORENRX=$G(PSOBBC("OIRXN"))
- I $G(PSORENRX) D PSOL^PSSLOCK(PSORENRX) I '$G(PSOMSG) D K DIR,PSOMSG W ! S DIR("A")="Press Return to continue",DIR(0)="E",DIR("?")="Press Return to continue" D ^DIR K DIR W ! Q
- .I $P($G(PSOMSG),"^",2)'="" W $C(7),!!,$P(PSOMSG,"^",2) Q
- .W $C(7),!!,"Another person is editing Rx "_$$GET1^DIQ(52,PSORENRX,.01,"I")
- K PSOMSG,PSOBBCLK S PSOBARCD=1 D PROCESS K PSOBARCD
- D KLIB^PSORENW1
- I $G(PSORENRX),$G(PSOBBCLK) D PSOUL^PSSLOCK(PSORENRX)
- K PSORENRX,PSOBBCLK
- Q
- CDOSE ;Validate Dosage field on Renewal, Copy, Edit
- ;PSOOCPRX must be set to internal Rx number
- Q:'$G(PSOOCPRX)
- N PSOOLP,PSOOKZ
- S PSOOLP="",(PSOOLPF,PSONOSIG)=0 F S PSOOLP=$O(^PSRX(PSOOCPRX,6,PSOOLP)) Q:PSOOLP=""!(PSOOLPF) I $P($G(^PSRX(PSOOCPRX,6,PSOOLP,0)),"^")["0.." S PSOOLPD=$P($G(^(0)),"^"),PSOOLPF=1
- Q:PSOOLPF
- S PSOOKZ=0
- I $P($G(^PSRX(PSOOCPRX,"SIG")),"^",2) S PSOOLP="" F S PSOOLP=$O(^PSRX(PSOOCPRX,"SIG1",PSOOLP)) Q:PSOOLP=""!(PSOOKZ) I $G(^PSRX(PSOOCPRX,"SIG1",PSOOLP,0))'="" S PSOOKZ=1
- I '$P($G(^PSRX(PSOOCPRX,"SIG")),"^",2),$P($G(^("SIG")),"^")'="" S PSOOKZ=1
- I 'PSOOKZ S PSONOSIG=1
- Q
- ;
- ALERT ; send an alert to the TWO approving team members
- N RSLT
- S XQADATA=PSCLPAT
- S PSOLAST4=$E($P($G(^DPT(PSCLPAT,0)),"^",9),6,9)
- S XQAARCH=1,XQAFLG="D"
- S XQA(PSO2PH)="",XQA(PSOUSER)="",PSCDATE=$$FMTE^XLFDT($$NOW^XLFDT)
- S XQAMSG=$$GET1^DIQ(2,PSCLPAT,.01)_" ("_PSOLAST4_")"_": Clozapine Override Rx Processed : "_PSCDATE
- S XQAID="PSI"_","_PSCLPAT
- S RSLT=$$SETUP1^XQALERT
- W !!,"OVERRIDE ALERTS HAVE BEEN SENT TO THE APPROVING TEAM MEMBERS",!!
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSORENW0 11012 printed Jan 18, 2025@03:34:53 Page 2
- PSORENW0 ;IHS/DSD/JCM-renew main driver continuation ;2/8/06 8:40am
- +1 ;;7.0;OUTPATIENT PHARMACY;**11,27,32,59,64,46,71,96,100,130,237,206,251,375,379,372,411,518,457,545**;DEC 1997;Build 270
- +2 ;External reference to ^PS(50.7 supported by DBIA 2223
- +3 ;External reference to ^PSDRUG( supported by DBIA 221
- +4 ;External reference to PSOL^PSSLOCK supported by DBIA 2789
- +5 ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
- +6 ;
- +7 ;PSO*237 was not adding to Clozapine Override file, fix
- PROCESS ;
- +1 DO ^PSORENW1
- +2 DO INST2^PSORENW
- +3 IF $DATA(PSORX("BAR CODE"))
- IF PSODFN'=PSORENW("PSODFN")
- DO NEWPT
- +4 SET PSORENW("DFLG")=0
- SET PSORENW("FILL DATE")=PSORNW("FILL DATE")
- +5 IF $GET(PSORNW("MAIL/WINDOW"))]""
- SET PSORENW("MAIL/WINDOW")=PSORNW("MAIL/WINDOW")
- +6 WRITE !!,"Now Renewing Rx # "_PSORENW("ORX #")_" Drug: "_$$GET1^DIQ(50,+$GET(PSORENW("DRUG IEN")),.01),!
- +7 DO CHECK
- if PSORENW("DFLG")
- GOTO PROCESSX
- +8 DO FILDATE
- +9 DO DRUG
- if PSORENW("DFLG")!PSORX("DFLG")
- GOTO PROCESSX
- +10 DO RXN
- if PSORENW("DFLG")
- GOTO PROCESSX
- +11 DO STOP^PSORENW1
- if $GET(PSOFDR)
- DO OERR^PSORENW1
- DSPL KILL PSOEDT,PSOLM
- DO DSPLY^PSORENW3
- if PSORENW("DFLG")
- GOTO PROCESSX
- +1 SET PSORENW("QFLG")=0
- if '$GET(PSOFDR)
- DO EDIT
- +2 if PSORENW("DFLG")!$GET(PSORX("FN"))
- GOTO PROCESSX
- +3 if '$GET(PSORX("FN"))&('$GET(PSORENW("QFLG")))
- GOTO DSPL
- +4 if $$FIND1^DIC(200.051,","_DUZ_",","X","PSORPH")!('$PIECE(PSOPAR,"^",2))
- DO VER1^PSOORNE4(.PSORENW)
- IF PSORENW("DFLG")=1
- GOTO PROCESSX
- +5 IF $GET(NEWDOSE)
- IF PSORENW("ENT")>0
- KILL NEWDOSE
- GOTO DSPL
- +6 DO EN^PSORN52(.PSORENW)
- +7 DO RNPSOSD^PSOUTIL
- +8 DO CAN
- DO DCORD^PSONEW2
- +9 SET BBRN1=$$FIND1^DIC(52,,"X",PSORENW("NRX #"))
- IF $$GET1^DIQ(52,BBRN1,11,"I")["W"
- SET BINGCRT="Y"
- SET BINGRTE="W"
- +10 ;PSO*237 add to Clozapine Override file
- ANQ IF $GET(ANQDATA)]""
- NEW PSOUSER,PSO1PH,PSO2PH,PSOREASN,PSOREMRK
- SET PSOUSER=$PIECE(ANQDATA,"^",5)
- SET PSO1PH=$PIECE(ANQDATA,"^")
- SET PSO2PH=$PIECE(ANQDATA,"^",5)
- SET PSOREASN=$PIECE(ANQDATA,"^",3)
- SET PSOREMRK=$PIECE(ANQDATA,"^",4)
- DO NOW^%DTC
- if $$FIND1^DIC(52.52,,"X",%)
- GOTO ANQ
- Begin DoDot:1
- +1 ;; ** START NCC REMEDIATION ** 457/RTW
- +2 NEW PSOUSER,PSO1PH,PSO2PH,PSOREASN,PSOREMRK,PSOPROV
- +3 SET PSOPROV=$PIECE(ANQDATA,"^",2)
- SET PSO1PH=$PIECE(ANQDATA,"^")
- SET PSO2PH=$PIECE(ANQDATA,"^",5)
- SET PSOREASN=$PIECE(ANQDATA,"^",3)
- SET PSOREMRK=$PIECE(ANQDATA,"^",4)
- +4 SET XQA(PSO2PH)=""
- SET XQA(PSOPROV)=""
- +5 IF $DATA(ORO)
- SET PSOPROV=$PIECE(ORO,"^",4)
- +6 KILL DD,DO
- SET DIC="^PS(52.52,"
- SET DIC(0)="L"
- SET DLAYGO=52.52
- SET X=%
- +7 DO FILE^DICN
- KILL DIC,DLAYGO,DD,DO,DA,DR
- +8 NEW PS52
- SET (PS52,DA)=+Y
- SET DIE="^PS(52.52,"
- SET DR="1////"_PSORENW("IRXN")_";2////"_PSO1PH_";3////"_PSOPROV_";4////"_PSOREASN_";5////"_PSOREMRK_";6////"_PSO2PH
- +9 DO ^DIE
- KILL DIE,DA,DR
- +10 KILL ANQDATA,X,Y,%,ANQREM
- +11 DO ALERT
- End DoDot:1
- +12 ; ** END NCC REMEDIATION ** 457/RTW
- +13 ;
- PROCESSX NEW PSORWRIT
- IF PSORENW("DFLG")!$GET(PSORX("DFLG"))
- SET PSOBBCLK=1
- if '$GET(POERR)
- WRITE !,$CHAR(7),"RENEWED RX DELETED",!
- SET PSOWRIT=1
- SET PSORERR=1
- Begin DoDot:1
- +1 if $PIECE($GET(PSOLST(+$GET(ORN))),"^",2)
- DO PSOUL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
- SET POERR("DFLG")=1
- DO CLEAN^PSOVER1
- Begin DoDot:2
- +2 WRITE !!
- KILL DIR
- SET DIR(0)="E"
- SET DIR("?")="Press Return to continue"
- SET DIR("A")="Press Return to Continue"
- DO ^DIR
- KILL DIR,DTOUT,DUOUT
- SET VALMBCK="Q"
- End DoDot:2
- End DoDot:1
- +3 if $GET(PSORENW("OLD FILL DATE"))]""
- DO SUSDATEK^PSOUTIL(.PSORENW)
- +4 ;*545
- KILL PRC,PHI,PSOQUIT,BBRN,BBRN1,PSORENW,PSODRUG,PSORX("PROVIDER NAME"),PSORX("CLINIC"),PSORX("FN"),PSORX("RXDEA"),PSORX("DETX")
- +5 KILL PSOEDT,PSOLM
- if $GET(PSORENW("FROM"))=""
- SET (PSORENW("DFLG"),PSORENW("QFLG"))=0
- +6 DO CLEAN^PSOVER1
- +7 QUIT
- +8 ;
- CHECK ;
- +1 IF '$DATA(PSORX("BAR CODE"))
- IF PSORENW("PSODFN")'=PSODFN
- Begin DoDot:1
- +2 WRITE !!,?5,$CHAR(7),"Can't renew Rx # "_$PIECE(PSORENW("RX0"),"^")_", it is not for this patient."
- SET PSORENW("DFLG")=1
- +3 if $GET(POERR)
- SET VALMSG="Can't renew Rx # "_$PIECE(PSORENW("RX0"),"^")_", not for this patient."
- SET VALMBCK="R"
- End DoDot:1
- GOTO CHECKX
- +4 ;Invalid dosage check
- +5 NEW PSOOCPRX,PSOOLPF,PSOOLPD,PSONOSIG
- SET PSOOCPRX=PSORENW("OIRXN")
- DO CDOSE
- +6 IF PSOOLPF!(PSONOSIG)
- Begin DoDot:1
- +7 SET PSORENW("DFLG")=1
- +8 WRITE !!,$CHAR(7),"Cannot renew Rx # "_$PIECE(PSORENW("RX0"),"^")_$SELECT(PSOOLPF:", invalid dosage of "_$GET(PSOOLPD),1:", Missing Sig")
- +9 if $GET(POERR)
- SET VALMSG="Cannot renew Rx # "_$PIECE(PSORENW("RX0"),"^")_$SELECT(PSOOLPF:", invalid Dosage of "_$GET(PSOOLPD),1:", Missing Sig")
- SET VALMBCK="R"
- +10 IF '$GET(PSORNSPD)
- WRITE !
- KILL DIR
- SET DIR(0)="E"
- SET DIR("?")="Press Return to continue"
- SET DIR("A")="Press Return to Continue"
- DO ^DIR
- KILL DIR
- +11 IF $GET(PSORNSPD)
- WRITE !
- End DoDot:1
- GOTO CHECKX
- +12 ;
- +13 NEW PSOS
- SET (PSOS,PSOX,PSOY)=""
- KILL ACOM,DIR,DIRUT,DIRUT,DUOUT
- NEW DRG
- +14 IF $GET(PSOSD)
- FOR
- SET PSOS=$ORDER(PSOSD(PSOS))
- if PSOS=""
- QUIT
- FOR
- SET PSOX=$ORDER(PSOSD(PSOS,PSOX))
- if PSOX']""!(PSORENW("DFLG"))
- QUIT
- IF PSORENW("OIRXN")=+PSOSD(PSOS,PSOX)
- SET PSOY=PSOSD(PSOS,PSOX)
- IF $TRANSLATE($PIECE(PSOY,"^",3),"B")]""
- Begin DoDot:1
- +15 SET PSORENW("DFLG")=1
- +16 WRITE !,$CHAR(7),"Cannot renew Rx # ",$PIECE(PSORENW("RX0"),"^")
- +17 SET PSOREA=$PIECE(PSOY,"^",3)
- SET PSOSTAT=+PSORENW("STA")
- +18 DO STATUS^PSOUTIL(PSOREA,PSOSTAT)
- KILL PSOREA,PSOSTAT
- +19 IF $GET(ACOM)]""
- Begin DoDot:2
- +20 SET DRG=$$GET1^DIQ(52,PSORENW("OIRXN"),6)
- +21 WRITE !
- SET DIR(0)="Y"
- SET DIR("A",1)="Do you want to Discontinue this Pending Order"
- SET DIR("A")="for "_DRG
- SET DIR("B")="No"
- +22 DO ^DIR
- IF 'Y!($DATA(DIRUT))
- QUIT
- +23 DO NOOR^PSOCAN4
- if $DATA(DIRUT)
- QUIT
- DO DE^PSOORFI2
- End DoDot:2
- +24 QUIT
- End DoDot:1
- KILL ACOM,DIR,DIRUT,DIRUT,DUOUT
- +25 IF PSOY=""
- IF '$GET(PSOORRNW)
- Begin DoDot:1
- +26 WRITE !,$CHAR(7),"Cannot renew Rx # ",$PIECE(PSORENW("RX0"),"^")," later Rx exists."
- SET PSORENW("DFLG")=1
- +27 if $GET(POERR)
- SET VALMSG="Cannot renew Rx # "_$PIECE(PSORENW("RX0"),"^")_" later Rx exists."
- SET VALMBCK="R"
- End DoDot:1
- +28 KILL PSOX,PSOY
- if PSORENW("DFLG")
- GOTO CHECKX
- +29 ;
- +30 IF $ASCII($EXTRACT(PSORENW("ORX #"),$LENGTH(PSORENW("ORX #"))))'<90
- Begin DoDot:1
- +31 WRITE !,$CHAR(7),"Cannot renew Rx # "_PSORENW("ORX #")_", Max number of renewals reached."
- +32 if $GET(POERR)!('$GET(SPEED))
- SET (ACOM,VALMSG)="Cannot renew Rx # "_PSORENW("ORX #")_", Max number reached."
- SET VALMBCK="R"
- +33 SET PSORENW("DFLG")=1
- +34 IF $GET(OR0)]""
- Begin DoDot:2
- +35 SET DRG=$$GET1^DIQ(52,PSORENW("OIRXN"),6)
- +36 WRITE !
- SET DIR(0)="Y"
- SET DIR("A",1)="Do you want to Discontinue this Pending Order"
- SET DIR("A")="for "_DRG
- SET DIR("B")="No"
- +37 DO ^DIR
- IF 'Y!($DATA(DIRUT))
- QUIT
- +38 DO NOOR^PSOCAN4
- if $DATA(DIRUT)
- QUIT
- DO DE^PSOORFI2
- End DoDot:2
- +39 KILL ACOM
- QUIT
- End DoDot:1
- QUIT
- +40 DO CHKDIV
- if PSORENW("DFLG")
- GOTO CHECKX
- +41 ;
- +42 DO CHKPRV^PSOUTIL
- CHECKX QUIT
- +1 ;
- CHKDIV ;
- +1 if $PIECE(PSORENW("RX2"),"^",9)=+PSOSITE
- GOTO CHKDIVX
- +2 WRITE !?5,$CHAR(7),"RX # ",$PIECE(PSORENW("RX0"),"^")," is for (",$$GET1^DIQ(59,$PIECE(PSORENW("RX2"),"^",9),.01),") division."
- +3 IF '$PIECE($GET(PSOSYS),"^",2)
- SET PSORENW("DFLG")=1
- GOTO CHKDIVX
- +4 if $PIECE($GET(PSOSYS),"^",3)
- DO DIR
- CHKDIVX QUIT
- +1 ;
- DRUG ;
- +1 KILL PSOY
- +2 SET PSOY=PSORENW("DRUG IEN")
- SET PSOY(0)=^PSDRUG(PSOY,0)
- SET PSORENWD=1
- +3 IF '$PIECE($GET(^PSDRUG(PSOY,2)),"^")
- Begin DoDot:1
- +4 IF $$GET1^DIQ(52,PSORENW("OIRXN"),39.2,"I")
- SET PSODRUG("OI")=$$GET1^DIQ(52,PSORENW("OIRXN"),39.2,"I")
- SET PSODRUG("OIN")=$$GET1^DIQ(52,PSORENW("OIRXN"),39.2)
- QUIT
- +5 WRITE !!,"Cannot Renew!! No Pharmacy Orderable Item!"
- SET VALMSG="Cannot Renew!! No Pharmacy Orderable Item!"
- SET PSORX("DFLG")=1
- End DoDot:1
- if $GET(PSORX("DFLG"))
- QUIT
- +6 DO SET^PSODRG
- +7 ;remove order checks for v7. do allergy checks only
- DO POST^PSODRG
- if 'PSORX("DFLG")
- DO DOSCK^PSODOSUT("R")
- if $GET(PSORX("DFLG"))
- SET PSORENW("DFLG")=1
- +8 SET PSONOOR=PSORENW("NOO")
- +9 KILL PSORX("INTERVENE")
- +10 if $DATA(PSONEW("STATUS"))
- SET PSORENW("STATUS")=PSONEW("STATUS")
- +11 KILL PSOY,PSONEW("STATUS"),PSORENWD
- +12 QUIT
- +13 ;
- RXN ;
- +1 KILL PSOX
- +2 SET PSOX=$EXTRACT(PSORENW("ORX #"),$LENGTH(PSORENW("ORX #")))
- +3 SET PSORENW("NRX #")=$SELECT(PSOX?1N:PSORENW("ORX #")_"A",1:$EXTRACT(PSORENW("ORX #"),1,$LENGTH(PSORENW("ORX #"))-1)_$CHAR($ASCII(PSOX)+1))
- RETRY IF $ORDER(^PSRX("B",PSORENW("NRX #"),0))
- Begin DoDot:1
- +1 if $ASCII($EXTRACT(PSORENW("NRX #"),$LENGTH(PSORENW("ORX #"))))'=90
- WRITE !,"Rx # "_PSORENW("NRX #")_" is already on file."
- +2 if $GET(PSOFDR)
- SET VALMSG="Rx # "_PSORENW("NRX #")_" is already on file."
- +3 IF $ASCII($EXTRACT(PSORENW("NRX #"),$LENGTH(PSORENW("ORX #"))))=90
- Begin DoDot:2
- +4 WRITE !,"Rx # "_PSORENW("NRX #")_" is already on file. Cannot renew Rx #"_PSORENW("ORX #")_".",!,"A new Rx must be entered.",!
- +5 if $GET(PSOFDR)
- SET VALMSG="Rx # "_PSORENW("NRX #")_" is already on file. Cannot renew Rx #"_PSORENW("ORX #")_". A new Rx must be entered."
- +6 KILL DIR
- SET DIR(0)="E"
- SET DIR("?")="Press Return to continue"
- SET DIR("A")="Press Return to Continue"
- DO ^DIR
- KILL DIR
- +7 if $GET(POERR)!($GET(PSOFDR))
- SET VALMSG="Cannot renew Rx # "_PSORENW("ORX #")_", Max number reached."
- SET VALMBCK="R"
- SET PSORENW("DFLG")=1
- End DoDot:2
- +8 SET PSOX=$EXTRACT(PSORENW("NRX #"),$LENGTH(PSORENW("NRX #")))
- +9 SET PSORENW("NRX #")=$SELECT(PSOX?1N:PSORENW("NRX #")_"A",1:$EXTRACT(PSORENW("NRX #"),1,$LENGTH(PSORENW("NRX #"))-1)_$CHAR($ASCII(PSOX)+1))
- End DoDot:1
- if '$GET(PSORENW("DFLG"))
- GOTO RETRY
- RXNX KILL PSOX
- +1 QUIT
- +2 ;
- FILDATE ;
- +1 SET PSORENW("IRXN")=PSORENW("OIRXN")
- +2 DO NEXT^PSOUTIL(.PSORENW)
- +3 IF PSORENW("FILL DATE")<$PIECE(PSORENW("RX3"),"^",2)
- Begin DoDot:1
- +4 DO RENFDT^PSOUTIL(.PSORENW)
- +5 IF PSORENW("FILL DATE")<DT
- IF PSORENW("FILL DATE")<PSORNW("FILL DATE")
- SET (Y,PSORENW("FILL DATE"))=DT
- XECUTE ^DD("DD")
- SET PSORX("FILL DATE")=Y
- KILL Y
- End DoDot:1
- +6 KILL PSORENW("IRXN")
- +7 QUIT
- +8 ;
- EDIT ;
- +1 KILL DIR,X,Y
- +2 SET DIR(0)="Y"
- SET DIR("B")=$SELECT($GET(DUZ("AG"))'="I":"Y",$GET(PSEXDT):"Y",1:"N")
- +3 SET DIR("A")="Edit renewed Rx "
- SET DIR("?")="Answer YES to edit the renewed Rx, NO not to."
- +4 DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- SET PSORENW("DFLG")=1
- +5 if PSORENW("DFLG")
- GOTO EDITX
- +6 KILL PSOQUIT,PSORX("FN")
- IF Y
- SET PSORNALL=1
- DO INIT^PSORENW3
- DO EN^PSOORNE4(.PSORENW)
- KILL PSORNALL
- if $GET(PSOQUIT)
- SET PSORENW("DFLG")=1
- IF '$GET(PSORX("FN"))
- DO FULL^VALM1
- QUIT
- +7 if $GET(PSORX("FN"))
- QUIT
- EDITX SET PSOEDT=1
- SET VALMBCK="Q"
- KILL X,Y,DIRUT,DTOUT,DUOUT
- SET PSORENW("QFLG")=1
- +1 QUIT
- +2 ;
- DELETE ;
- +1 KILL DA,DIK
- +2 SET DA=$ORDER(^PS(52.5,"B",PSORENW("OIRXN"),0))
- SET DIK="^PS(52.5,"
- +3 DO ^DIK
- KILL DIK,DIC
- +4 QUIT
- +5 ;
- CAN ;
- +1 KILL REA,DA,MSG
- +2 SET REA="C"
- SET DA=PSORENW("OIRXN")
- +3 SET MSG="Renewed"_$SELECT($GET(PSOFDR):" from CPRS",1:"")
- +4 SET PSCAN(PSORENW("ORX #"))=DA_"^C"
- +5 DO CAN^PSOCAN
- +6 KILL REA,DA,MSG,PSCAN
- +7 QUIT
- +8 ;
- DIR ;
- +1 SET DIR(0)="Y"
- SET DIR("A")="CONTINUE "
- SET DIR("B")="N"
- +2 SET DIR("?")="Answer YES to Continue, NO to bypass"
- +3 DO ^DIR
- KILL DIR
- +4 if $DATA(DIRUT)!('Y)
- SET PSORENW("DFLG")=1
- DIRX KILL DIRUT,DTOUT,DUOUT,X,Y
- +1 QUIT
- NEWPT ;
- +1 SET PSOQFLG=0
- NEW PSODFN
- +2 SET PSODFN=PSORENW("PSODFN")
- +3 DO ^PSOPTPST
- IF PSOQFLG
- SET PSORENW("DFLG")=1
- SET PSOQFLG=0
- GOTO NEWPTX
- +4 DO PROFILE^PSOREF1
- NEWPTX QUIT
- +1 ;
- EN(PSORENW) ; Entry Point for Batch Barcode Option
- +1 SET PSORENRX=$GET(PSOBBC("OIRXN"))
- +2 IF $GET(PSORENRX)
- DO PSOL^PSSLOCK(PSORENRX)
- IF '$GET(PSOMSG)
- Begin DoDot:1
- +3 IF $PIECE($GET(PSOMSG),"^",2)'=""
- WRITE $CHAR(7),!!,$PIECE(PSOMSG,"^",2)
- QUIT
- +4 WRITE $CHAR(7),!!,"Another person is editing Rx "_$$GET1^DIQ(52,PSORENRX,.01,"I")
- End DoDot:1
- KILL DIR,PSOMSG
- WRITE !
- SET DIR("A")="Press Return to continue"
- SET DIR(0)="E"
- SET DIR("?")="Press Return to continue"
- DO ^DIR
- KILL DIR
- WRITE !
- QUIT
- +5 KILL PSOMSG,PSOBBCLK
- SET PSOBARCD=1
- DO PROCESS
- KILL PSOBARCD
- +6 DO KLIB^PSORENW1
- +7 IF $GET(PSORENRX)
- IF $GET(PSOBBCLK)
- DO PSOUL^PSSLOCK(PSORENRX)
- +8 KILL PSORENRX,PSOBBCLK
- +9 QUIT
- CDOSE ;Validate Dosage field on Renewal, Copy, Edit
- +1 ;PSOOCPRX must be set to internal Rx number
- +2 if '$GET(PSOOCPRX)
- QUIT
- +3 NEW PSOOLP,PSOOKZ
- +4 SET PSOOLP=""
- SET (PSOOLPF,PSONOSIG)=0
- FOR
- SET PSOOLP=$ORDER(^PSRX(PSOOCPRX,6,PSOOLP))
- if PSOOLP=""!(PSOOLPF)
- QUIT
- IF $PIECE($GET(^PSRX(PSOOCPRX,6,PSOOLP,0)),"^")["0.."
- SET PSOOLPD=$PIECE($GET(^(0)),"^")
- SET PSOOLPF=1
- +5 if PSOOLPF
- QUIT
- +6 SET PSOOKZ=0
- +7 IF $PIECE($GET(^PSRX(PSOOCPRX,"SIG")),"^",2)
- SET PSOOLP=""
- FOR
- SET PSOOLP=$ORDER(^PSRX(PSOOCPRX,"SIG1",PSOOLP))
- if PSOOLP=""!(PSOOKZ)
- QUIT
- IF $GET(^PSRX(PSOOCPRX,"SIG1",PSOOLP,0))'=""
- SET PSOOKZ=1
- +8 IF '$PIECE($GET(^PSRX(PSOOCPRX,"SIG")),"^",2)
- IF $PIECE($GET(^("SIG")),"^")'=""
- SET PSOOKZ=1
- +9 IF 'PSOOKZ
- SET PSONOSIG=1
- +10 QUIT
- +11 ;
- ALERT ; send an alert to the TWO approving team members
- +1 NEW RSLT
- +2 SET XQADATA=PSCLPAT
- +3 SET PSOLAST4=$EXTRACT($PIECE($GET(^DPT(PSCLPAT,0)),"^",9),6,9)
- +4 SET XQAARCH=1
- SET XQAFLG="D"
- +5 SET XQA(PSO2PH)=""
- SET XQA(PSOUSER)=""
- SET PSCDATE=$$FMTE^XLFDT($$NOW^XLFDT)
- +6 SET XQAMSG=$$GET1^DIQ(2,PSCLPAT,.01)_" ("_PSOLAST4_")"_": Clozapine Override Rx Processed : "_PSCDATE
- +7 SET XQAID="PSI"_","_PSCLPAT
- +8 SET RSLT=$$SETUP1^XQALERT
- +9 WRITE !!,"OVERRIDE ALERTS HAVE BEEN SENT TO THE APPROVING TEAM MEMBERS",!!
- +10 QUIT
- +11 ;