Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSORENW0

PSORENW0.m

Go to the documentation of this file.
  1. 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
  1. ;External reference to ^PS(50.7 supported by DBIA 2223
  1. ;External reference to ^PSDRUG( supported by DBIA 221
  1. ;External reference to PSOL^PSSLOCK supported by DBIA 2789
  1. ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
  1. ;
  1. ;PSO*237 was not adding to Clozapine Override file, fix
  1. PROCESS ;
  1. D ^PSORENW1
  1. D INST2^PSORENW
  1. I $D(PSORX("BAR CODE")),PSODFN'=PSORENW("PSODFN") D NEWPT
  1. S PSORENW("DFLG")=0,PSORENW("FILL DATE")=PSORNW("FILL DATE")
  1. I $G(PSORNW("MAIL/WINDOW"))]"" S PSORENW("MAIL/WINDOW")=PSORNW("MAIL/WINDOW")
  1. W !!,"Now Renewing Rx # "_PSORENW("ORX #")_" Drug: "_$$GET1^DIQ(50,+$G(PSORENW("DRUG IEN")),.01),!
  1. D CHECK G:PSORENW("DFLG") PROCESSX
  1. D FILDATE
  1. D DRUG G:PSORENW("DFLG")!PSORX("DFLG") PROCESSX
  1. D RXN G:PSORENW("DFLG") PROCESSX
  1. D STOP^PSORENW1,OERR^PSORENW1:$G(PSOFDR)
  1. DSPL K PSOEDT,PSOLM D DSPLY^PSORENW3 G:PSORENW("DFLG") PROCESSX
  1. S PSORENW("QFLG")=0 D:'$G(PSOFDR) EDIT
  1. G:PSORENW("DFLG")!$G(PSORX("FN")) PROCESSX
  1. G:'$G(PSORX("FN"))&('$G(PSORENW("QFLG"))) DSPL
  1. D:$$FIND1^DIC(200.051,","_DUZ_",","X","PSORPH")!('$P(PSOPAR,"^",2)) VER1^PSOORNE4(.PSORENW) I PSORENW("DFLG")=1 G PROCESSX
  1. I $G(NEWDOSE),PSORENW("ENT")>0 K NEWDOSE G DSPL
  1. D EN^PSORN52(.PSORENW)
  1. D RNPSOSD^PSOUTIL
  1. D CAN,DCORD^PSONEW2
  1. S BBRN1=$$FIND1^DIC(52,,"X",PSORENW("NRX #")) I $$GET1^DIQ(52,BBRN1,11,"I")["W" S BINGCRT="Y",BINGRTE="W"
  1. ;PSO*237 add to Clozapine Override file
  1. 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
  1. .;; ** START NCC REMEDIATION ** 457/RTW
  1. .N PSOUSER,PSO1PH,PSO2PH,PSOREASN,PSOREMRK,PSOPROV
  1. .S PSOPROV=$P(ANQDATA,"^",2),PSO1PH=$P(ANQDATA,"^"),PSO2PH=$P(ANQDATA,"^",5),PSOREASN=$P(ANQDATA,"^",3),PSOREMRK=$P(ANQDATA,"^",4)
  1. .S XQA(PSO2PH)="",XQA(PSOPROV)=""
  1. .I $D(ORO) S PSOPROV=$P(ORO,"^",4)
  1. .K DD,DO S DIC="^PS(52.52,",DIC(0)="L",DLAYGO=52.52,X=%
  1. .D FILE^DICN K DIC,DLAYGO,DD,DO,DA,DR
  1. .N PS52 S (PS52,DA)=+Y,DIE="^PS(52.52,",DR="1////"_PSORENW("IRXN")_";2////"_PSO1PH_";3////"_PSOPROV_";4////"_PSOREASN_";5////"_PSOREMRK_";6////"_PSO2PH
  1. .D ^DIE K DIE,DA,DR
  1. .K ANQDATA,X,Y,%,ANQREM
  1. .D ALERT
  1. ; ** END NCC REMEDIATION ** 457/RTW
  1. ;
  1. 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
  1. .D:$P($G(PSOLST(+$G(ORN))),"^",2) PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) S POERR("DFLG")=1 D CLEAN^PSOVER1 D
  1. ..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"
  1. D:$G(PSORENW("OLD FILL DATE"))]"" SUSDATEK^PSOUTIL(.PSORENW)
  1. K PRC,PHI,PSOQUIT,BBRN,BBRN1,PSORENW,PSODRUG,PSORX("PROVIDER NAME"),PSORX("CLINIC"),PSORX("FN"),PSORX("RXDEA"),PSORX("DETX") ;*545
  1. K PSOEDT,PSOLM S:$G(PSORENW("FROM"))="" (PSORENW("DFLG"),PSORENW("QFLG"))=0
  1. D CLEAN^PSOVER1
  1. Q
  1. ;
  1. CHECK ;
  1. I '$D(PSORX("BAR CODE")),PSORENW("PSODFN")'=PSODFN D G CHECKX
  1. .W !!,?5,$C(7),"Can't renew Rx # "_$P(PSORENW("RX0"),"^")_", it is not for this patient." S PSORENW("DFLG")=1
  1. .S:$G(POERR) VALMSG="Can't renew Rx # "_$P(PSORENW("RX0"),"^")_", not for this patient.",VALMBCK="R"
  1. ;Invalid dosage check
  1. N PSOOCPRX,PSOOLPF,PSOOLPD,PSONOSIG S PSOOCPRX=PSORENW("OIRXN") D CDOSE
  1. I PSOOLPF!(PSONOSIG) D G CHECKX
  1. .S PSORENW("DFLG")=1
  1. .W !!,$C(7),"Cannot renew Rx # "_$P(PSORENW("RX0"),"^")_$S(PSOOLPF:", invalid dosage of "_$G(PSOOLPD),1:", Missing Sig")
  1. .S:$G(POERR) VALMSG="Cannot renew Rx # "_$P(PSORENW("RX0"),"^")_$S(PSOOLPF:", invalid Dosage of "_$G(PSOOLPD),1:", Missing Sig") S VALMBCK="R"
  1. .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
  1. .I $G(PSORNSPD) W !
  1. ;
  1. N PSOS S (PSOS,PSOX,PSOY)="" K ACOM,DIR,DIRUT,DIRUT,DUOUT N DRG
  1. 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
  1. . S PSORENW("DFLG")=1
  1. . W !,$C(7),"Cannot renew Rx # ",$P(PSORENW("RX0"),"^")
  1. . S PSOREA=$P(PSOY,"^",3),PSOSTAT=+PSORENW("STA")
  1. . D STATUS^PSOUTIL(PSOREA,PSOSTAT) K PSOREA,PSOSTAT
  1. .I $G(ACOM)]"" D
  1. ..S DRG=$$GET1^DIQ(52,PSORENW("OIRXN"),6)
  1. ..W ! S DIR(0)="Y",DIR("A",1)="Do you want to Discontinue this Pending Order",DIR("A")="for "_DRG,DIR("B")="No"
  1. ..D ^DIR I 'Y!($D(DIRUT)) Q
  1. ..D NOOR^PSOCAN4 Q:$D(DIRUT) D DE^PSOORFI2
  1. .Q
  1. I PSOY="",'$G(PSOORRNW) D
  1. .W !,$C(7),"Cannot renew Rx # ",$P(PSORENW("RX0"),"^")," later Rx exists." S PSORENW("DFLG")=1
  1. .S:$G(POERR) VALMSG="Cannot renew Rx # "_$P(PSORENW("RX0"),"^")_" later Rx exists.",VALMBCK="R"
  1. K PSOX,PSOY G:PSORENW("DFLG") CHECKX
  1. ;
  1. I $A($E(PSORENW("ORX #"),$L(PSORENW("ORX #"))))'<90 D Q
  1. . W !,$C(7),"Cannot renew Rx # "_PSORENW("ORX #")_", Max number of renewals reached."
  1. .S:$G(POERR)!('$G(SPEED)) (ACOM,VALMSG)="Cannot renew Rx # "_PSORENW("ORX #")_", Max number reached.",VALMBCK="R"
  1. . S PSORENW("DFLG")=1
  1. .I $G(OR0)]"" D
  1. ..S DRG=$$GET1^DIQ(52,PSORENW("OIRXN"),6)
  1. ..W ! S DIR(0)="Y",DIR("A",1)="Do you want to Discontinue this Pending Order",DIR("A")="for "_DRG,DIR("B")="No"
  1. ..D ^DIR I 'Y!($D(DIRUT)) Q
  1. ..D NOOR^PSOCAN4 Q:$D(DIRUT) D DE^PSOORFI2
  1. .K ACOM Q
  1. D CHKDIV G:PSORENW("DFLG") CHECKX
  1. ;
  1. D CHKPRV^PSOUTIL
  1. CHECKX Q
  1. ;
  1. CHKDIV ;
  1. G:$P(PSORENW("RX2"),"^",9)=+PSOSITE CHKDIVX
  1. W !?5,$C(7),"RX # ",$P(PSORENW("RX0"),"^")," is for (",$$GET1^DIQ(59,$P(PSORENW("RX2"),"^",9),.01),") division."
  1. I '$P($G(PSOSYS),"^",2) S PSORENW("DFLG")=1 G CHKDIVX
  1. D:$P($G(PSOSYS),"^",3) DIR
  1. CHKDIVX Q
  1. ;
  1. DRUG ;
  1. K PSOY
  1. S PSOY=PSORENW("DRUG IEN"),PSOY(0)=^PSDRUG(PSOY,0),PSORENWD=1
  1. I '$P($G(^PSDRUG(PSOY,2)),"^") D Q:$G(PSORX("DFLG"))
  1. .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
  1. .W !!,"Cannot Renew!! No Pharmacy Orderable Item!" S VALMSG="Cannot Renew!! No Pharmacy Orderable Item!",PSORX("DFLG")=1
  1. D SET^PSODRG
  1. 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
  1. S PSONOOR=PSORENW("NOO")
  1. K PSORX("INTERVENE")
  1. S:$D(PSONEW("STATUS")) PSORENW("STATUS")=PSONEW("STATUS")
  1. K PSOY,PSONEW("STATUS"),PSORENWD
  1. Q
  1. ;
  1. RXN ;
  1. K PSOX
  1. S PSOX=$E(PSORENW("ORX #"),$L(PSORENW("ORX #")))
  1. S PSORENW("NRX #")=$S(PSOX?1N:PSORENW("ORX #")_"A",1:$E(PSORENW("ORX #"),1,$L(PSORENW("ORX #"))-1)_$C($A(PSOX)+1))
  1. RETRY I $O(^PSRX("B",PSORENW("NRX #"),0)) D G:'$G(PSORENW("DFLG")) RETRY
  1. .W:$A($E(PSORENW("NRX #"),$L(PSORENW("ORX #"))))'=90 !,"Rx # "_PSORENW("NRX #")_" is already on file."
  1. .S:$G(PSOFDR) VALMSG="Rx # "_PSORENW("NRX #")_" is already on file."
  1. .I $A($E(PSORENW("NRX #"),$L(PSORENW("ORX #"))))=90 D
  1. ..W !,"Rx # "_PSORENW("NRX #")_" is already on file. Cannot renew Rx #"_PSORENW("ORX #")_".",!,"A new Rx must be entered.",!
  1. ..S:$G(PSOFDR) VALMSG="Rx # "_PSORENW("NRX #")_" is already on file. Cannot renew Rx #"_PSORENW("ORX #")_". A new Rx must be entered."
  1. ..K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to Continue" D ^DIR K DIR
  1. ..S:$G(POERR)!($G(PSOFDR)) VALMSG="Cannot renew Rx # "_PSORENW("ORX #")_", Max number reached.",VALMBCK="R" S PSORENW("DFLG")=1
  1. .S PSOX=$E(PSORENW("NRX #"),$L(PSORENW("NRX #")))
  1. .S PSORENW("NRX #")=$S(PSOX?1N:PSORENW("NRX #")_"A",1:$E(PSORENW("NRX #"),1,$L(PSORENW("NRX #"))-1)_$C($A(PSOX)+1))
  1. RXNX K PSOX
  1. Q
  1. ;
  1. FILDATE ;
  1. S PSORENW("IRXN")=PSORENW("OIRXN")
  1. D NEXT^PSOUTIL(.PSORENW)
  1. I PSORENW("FILL DATE")<$P(PSORENW("RX3"),"^",2) D
  1. .D RENFDT^PSOUTIL(.PSORENW)
  1. .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
  1. K PSORENW("IRXN")
  1. Q
  1. ;
  1. EDIT ;
  1. K DIR,X,Y
  1. S DIR(0)="Y",DIR("B")=$S($G(DUZ("AG"))'="I":"Y",$G(PSEXDT):"Y",1:"N")
  1. S DIR("A")="Edit renewed Rx ",DIR("?")="Answer YES to edit the renewed Rx, NO not to."
  1. D ^DIR K DIR S:$D(DIRUT) PSORENW("DFLG")=1
  1. G:PSORENW("DFLG") EDITX
  1. 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
  1. Q:$G(PSORX("FN"))
  1. EDITX S PSOEDT=1,VALMBCK="Q" K X,Y,DIRUT,DTOUT,DUOUT S PSORENW("QFLG")=1
  1. Q
  1. ;
  1. DELETE ;
  1. K DA,DIK
  1. S DA=$O(^PS(52.5,"B",PSORENW("OIRXN"),0)),DIK="^PS(52.5,"
  1. D ^DIK K DIK,DIC
  1. Q
  1. ;
  1. CAN ;
  1. K REA,DA,MSG
  1. S REA="C",DA=PSORENW("OIRXN")
  1. S MSG="Renewed"_$S($G(PSOFDR):" from CPRS",1:"")
  1. S PSCAN(PSORENW("ORX #"))=DA_"^C"
  1. D CAN^PSOCAN
  1. K REA,DA,MSG,PSCAN
  1. Q
  1. ;
  1. DIR ;
  1. S DIR(0)="Y",DIR("A")="CONTINUE ",DIR("B")="N"
  1. S DIR("?")="Answer YES to Continue, NO to bypass"
  1. D ^DIR K DIR
  1. S:$D(DIRUT)!('Y) PSORENW("DFLG")=1
  1. DIRX K DIRUT,DTOUT,DUOUT,X,Y
  1. Q
  1. NEWPT ;
  1. S PSOQFLG=0 N PSODFN
  1. S PSODFN=PSORENW("PSODFN")
  1. D ^PSOPTPST I PSOQFLG S PSORENW("DFLG")=1,PSOQFLG=0 G NEWPTX
  1. D PROFILE^PSOREF1
  1. NEWPTX Q
  1. ;
  1. EN(PSORENW) ; Entry Point for Batch Barcode Option
  1. S PSORENRX=$G(PSOBBC("OIRXN"))
  1. 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
  1. .I $P($G(PSOMSG),"^",2)'="" W $C(7),!!,$P(PSOMSG,"^",2) Q
  1. .W $C(7),!!,"Another person is editing Rx "_$$GET1^DIQ(52,PSORENRX,.01,"I")
  1. K PSOMSG,PSOBBCLK S PSOBARCD=1 D PROCESS K PSOBARCD
  1. D KLIB^PSORENW1
  1. I $G(PSORENRX),$G(PSOBBCLK) D PSOUL^PSSLOCK(PSORENRX)
  1. K PSORENRX,PSOBBCLK
  1. Q
  1. CDOSE ;Validate Dosage field on Renewal, Copy, Edit
  1. ;PSOOCPRX must be set to internal Rx number
  1. Q:'$G(PSOOCPRX)
  1. N PSOOLP,PSOOKZ
  1. 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
  1. Q:PSOOLPF
  1. S PSOOKZ=0
  1. 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
  1. I '$P($G(^PSRX(PSOOCPRX,"SIG")),"^",2),$P($G(^("SIG")),"^")'="" S PSOOKZ=1
  1. I 'PSOOKZ S PSONOSIG=1
  1. Q
  1. ;
  1. ALERT ; send an alert to the TWO approving team members
  1. N RSLT
  1. S XQADATA=PSCLPAT
  1. S PSOLAST4=$E($P($G(^DPT(PSCLPAT,0)),"^",9),6,9)
  1. S XQAARCH=1,XQAFLG="D"
  1. S XQA(PSO2PH)="",XQA(PSOUSER)="",PSCDATE=$$FMTE^XLFDT($$NOW^XLFDT)
  1. S XQAMSG=$$GET1^DIQ(2,PSCLPAT,.01)_" ("_PSOLAST4_")"_": Clozapine Override Rx Processed : "_PSCDATE
  1. S XQAID="PSI"_","_PSCLPAT
  1. S RSLT=$$SETUP1^XQALERT
  1. W !!,"OVERRIDE ALERTS HAVE BEEN SENT TO THE APPROVING TEAM MEMBERS",!!
  1. Q
  1. ;