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

PSOORED1.m

Go to the documentation of this file.
  1. PSOORED1 ;ISC-BHAM/SAB - edit orders from backdoor ;Oct 20, 2022@15:19
  1. ;;7.0;OUTPATIENT PHARMACY;**5,23,46,78,114,117,131,146,223,148,244,249,268,206,313,444,422,457,649,441,545,753**;DEC 1997;Build 53
  1. ;External reference ^PS(55 supported by DBIA 2228
  1. ;External reference ^PS(50.7 supported by DBIA 2223
  1. ;
  1. ;*244 call to remove DC'd Rx's from Rx ien strings
  1. ;
  1. EN(PSORENW) ;
  1. N LST,ORD,ORN K VALMBCK,PSORX("FN") S PSOAC=1,(PSORX("QFLG"),PSORX("DFLG"))=0 ;D DREN^PSOORNW2,INIT
  1. D INIT
  1. D @$S($P(PSOPAR,"^",7):"AUTO^PSONRXN",1:"MANUAL^PSONRXN")
  1. I '$D(PSONEW("RX #")),'$P(PSOPAR,"^",7) D PAUSE^VALM1 K VALMSG,PSONEW("QFLG") S VALMBCK="Q" Q
  1. I '$D(PSONEW("RX #")) K VALMSG D DEL^PSONEW,PAUSE^VALM1 S VALMBCK="Q" Q
  1. S PSORENW("RX #")=PSONEW("RX #") I '$P(PSOPAR,"^",7) D Q:$G(PSONEW("DFLG"))!($G(PSONEW("QFLG")))
  1. .S PSOX=PSORENW("RX #") D CHECK^PSONRXN
  1. I $G(PSONEW("DFLG"))!$G(PSONEW("QFLG")) D DEL^PSONEW,PAUSE^VALM1 S VALMBCK="Q" K PSORENW Q
  1. D EN^PSOORNE1(.PSORENW) I '$G(PSORX("FN")) D:$P($G(PSOPAR),"^",7)=1 S VALMBCK="Q" Q
  1. .S DIE="^PS(59,",DA=PSOSITE,PSOY=$O(PSONEW("OLD LAST RX#","")),PSOX=PSONEW("OLD LAST RX#",PSOY)
  1. .L +^PS(59,+PSOSITE,PSOY):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
  1. .S DR=$S(PSOY=8:"2003////"_PSOX,PSOY=3:"1002.1////"_PSOX,1:"2003////"_PSOX)
  1. .D:PSOX<$P(^PS(59,+PSOSITE,PSOY),"^",3) ^DIE K DIE,X,Y L -^PS(59,+PSOSITE,PSOY)
  1. .I $D(PSONEW("RX #")) L -^PSRX("B",PSONEW("RX #"))
  1. .K PSOX,PSOY Q
  1. Q:$G(COPY)
  1. TRY S $P(^PSRX(PSORENW("OIRXN"),"STA"),"^")=15,DA=PSORENW("OIRXN")
  1. S $P(^PSRX(DA,3),"^",5)=DT,$P(^PSRX(DA,3),"^",10)=$P(^PSRX(DA,3),"^")
  1. D REVERSE^PSOBPSU1(DA,,"DC",7),CAN^PSOTPCAN(DA)
  1. D RMP^PSOCAN3 ;*244
  1. ;cancel/discontinue action
  1. S PHARM="",STAT="RP",COMM="Prescription discontinued due to editing." D EN^PSOHLSN1(DA,STAT,PHARM,COMM,PSONOOR) K STAT,PHARM,COMM
  1. S ACOM="Discontinued due to editing. New Rx created "_$P(^PSRX(PSORENW("IRXN"),0),"^")_"."
  1. I $G(^PSRX(DA,"H"))]"" D
  1. .I $P(^PSRX(DA,"STA"),"^")=3!($P(^("STA"),"^")=16) D
  1. ..S DIE=52,DR="22///"_$P(^PSRX(DA,3),"^") D ^DIE S ACOM="Discontinued due to editing while on hold. " K:$P(^PSRX(DA,"H"),"^") ^PSRX("AH",$P(^PSRX(DA,"H"),"^"),DA)
  1. ..S ^PSRX(DA,"H")=""
  1. S RXDA=DA,(DA,SUSDA)=$O(^PS(52.5,"B",RXDA,0)) D:DA
  1. .S SUSD=$P($G(^PS(52.5,DA,0)),"^",2)
  1. .S:+$G(^PS(52.5,DA,"P"))'=1 ACOM="Discontinued due to editing while suspended."
  1. .I $O(^PSRX(RXDA,1,0)) S DA=RXDA D:'$G(^PS(52.5,+SUSDA,"P")) REF^PSOCAN2
  1. .S DA=SUSDA,DIK="^PS(52.5," D ^DIK K DIK
  1. K SUSD,SUSDA S DA=RXDA,RXREF=0,PSODFN=+$P(^PSRX(DA,0),"^",2) D
  1. .S ACNT=0 F SUB=0:0 S SUB=$O(^PSRX(DA,"A",SUB)) Q:'SUB S ACNT=SUB
  1. .S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(DA,1,RF)) Q:'RF S RFCNT=RF S:RF>5 RFCNT=RF+1
  1. .D NOW^%DTC S ^PSRX(DA,"A",0)="^52.3DA^"_(ACNT+1)_"^"_(ACNT+1),^PSRX(DA,"A",ACNT+1,0)=%_"^C^"_DUZ_"^"_RFCNT_"^"_$G(ACOM)
  1. .I $G(PSOOIFLG),'$G(PSOMRFLG) S $P(^PSRX(DA,"A",ACNT+1,1),"^")="Pharmacy Orderable Item Edited."
  1. .I '$G(PSOOIFLG),$G(PSOMRFLG) S $P(^PSRX(DA,"A",ACNT+1,1),"^")="Medication Route/Schedule Edited."
  1. .I $G(PSOOIFLG),$G(PSOMRFLG) S $P(^PSRX(DA,"A",ACNT+1,1),"^")="Pharmacy Orderable Item and Medication Route/Schedule Edited."
  1. .S REA="C" D EXP^PSOHELP1
  1. I $G(^PS(52.4,DA,0))]"" S PSCDA=DA,DIK="^PS(52.4," D ^DIK S DA=PSCDA K DIK,PSCDA
  1. Q
  1. INS K X,QUIT,Y,DIR,DIRUT,DUOUT,DTOUT,DIC,INSDEL,UPMI,^TMP($J,"INS1")
  1. I '$O(^PSRX(PSORXED("IRXN"),6,0)),'$O(PSORXED("DOSE",0)) D UPMI Q:$G(QUIT) ;G INS1
  1. I $G(^PSRX(PSORXED("IRXN"),"INS"))]"" S PSORXED("FLD",114)=^PSRX(PSORXED("IRXN"),"INS") K UPMI G INS1
  1. K DD,GG F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),"INS1",I)) Q:'I S DD=$G(DD)+1
  1. I $G(DD)=1 S PSORXED("FLD",114)=^PSRX(PSORXED("IRXN"),"INS1",$O(^PSRX(PSORXED("IRXN"),"INS1",0)),0) K UPMI,DD G INS1
  1. I $O(^PSRX(PSORXED("IRXN"),"INS1",0)) D G INSX
  1. .F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),"INS1",I)) Q:'I S ^TMP($J,"INS1",I,0)=^PSRX(PSORXED("IRXN"),"INS1",I,0)
  1. .S ^TMP($J,"INS1",0)=^PSRX(PSORXED("IRXN"),"INS1",0)
  1. .S DIC="^TMP($J,""INS1"",",DWPK=2,DWLW=80 D EN^DIWE I $G(X)="^" K ^TMP($J,"INS1") Q
  1. .I '$O(^TMP($J,"INS1",0)) S INSDEL=1
  1. .S D=0 F S D=$O(^PSRX(PSORXED("IRXN"),"INS1",D)) Q:'D S (PSORXED("SIG",D),PSORXED("INS",D))=^PSRX(PSORXED("IRXN"),"INS1",D,0)
  1. INS1 K Y,DIR,DIRUT,DUOUT,DTOUT,DIC,X
  1. I $G(PSORXED("IRXN")) S:'$D(PSOOEINS) PSOOEINS=$G(^PSRX(PSORXED("IRXN"),"INS")) S:'$D(PSOOSINS) PSOOSINS=$G(^PSRX(PSORXED("IRXN"),"INSS")) ;*422
  1. I $G(UPMI) K UPMI I $G(^PS(50.7,PSODRUG("OI"),"INS"))]"" S PSORXED("FLD",114)=^PS(50.7,PSODRUG("OI"),"INS")
  1. S:$G(PSORXED("FLD",114))]"" DIR("B")=PSORXED("FLD",114)
  1. S DIR("?")="Enter Quick codes or Free Text",DIR(0)="52,114" D ^DIR
  1. I $D(DTOUT)!($D(DUOUT)) K PSORXED("FLD",114),PSORXED("FLD",114.1) S (PSORXED("INS"),PSORXED("SIG",1))=$G(PSOOEINS) S:$P($G(^PS(55,PSODFN,"LAN")),"^") PSORXED("SINS")=$G(PSOOSINS) D EN^PSOFSIG(.PSORXED,1) G INSQX ;*422
  1. I $G(PSORXED("DFLG")) S (PSORXED("SIG"),PSORXED("INS"))=$G(PSOOEINS),PSORXED("SINS")=$G(PSOOSINS) K PSORXED("SIG") D EN^PSOFSIG(.PSONEW,1) G INSQX ;*422
  1. S PSODELINS=0 I X="@" S PSODELINS=1 D DELINS^PSOHELP3 ;*422
  1. I '$G(PSODELINS),($G(X)="@"!($G(X)="")) S (X,INS1,PSORXED("INS"))=$G(PSOOEINS) ;*422
  1. I $G(PSODELINS) S (INS1,PSORXED("FLD",114),PSORXED("FLD",114.1))="" K PSORXED("INS"),PSORXED("SIG"),PSORXED("SINS") ;*422
  1. I X'="",X'="@" D SIG^PSOHELP G INS1:'$D(X)
  1. I $G(INS1)]"" W " ("_$E(INS1,2,9999999)_")"
  1. S:$G(INS1)]"" (PSORXED("INS"),PSORXED("SIG",1),PSORXED("FLD",114))=$E(INS1,2,9999999) D EN^PSOFSIG(.PSORXED)
  1. I $G(PSODELINS) G INSQ
  1. INSX I '$P($G(^PS(55,PSODFN,"LAN")),"^") G INSQ
  1. K DIR
  1. I $G(^PSRX(PSORXED("IRXN"),"INSS"))]"" S PSORXED("SINS")=^PSRX(PSORXED("IRXN"),"INSS")
  1. D SINS^PSODIR(.PSORXED) ;*422
  1. I $G(PSORXED("DFLG")) K PSORXED("FLD",114) S PSORXED("INS")=$G(PSOOEINS) S:$P($G(^PS(55,PSODFN,"LAN")),"^") PSORXED("SINS")=$G(PSOOSINS) D EN^PSOFSIG(.PSORXED,1) G INSQ ;*422
  1. S:$G(PSORXED("SINS"))]"" PSORXED("FLD",114.1)=$G(PSORXED("SINS")) ;*422
  1. S PSOINSCH=$$INSCHK^PSOHELP3(.PSORXED) ;*422
  1. G:PSOINSCH INS ;*422
  1. INSQ ;
  1. ;441-IND
  1. I '$P($G(^PS(55,PSODFN,"LAN")),"^") D
  1. . S (PSORXED("IND"),PSORXED("FLD",128))=$P($G(^PSRX(PSORXED("IRXN"),"IND")),"^"),(PSORXED("INDF"),PSORXED("FLD",129))=$P($G(^PSRX(PSORXED("IRXN"),"IND")),"^",2)
  1. . D INDICAT^PSODIR(.PSORXED)
  1. . I $D(DTOUT)!($D(DUOUT)) K PSORXED("FLD",128),PSORXED("FLD",129) Q
  1. . D EN^PSOFSIG(.PSORXED)
  1. I $P($G(^PS(55,PSODFN,"LAN")),"^") D
  1. . S (PSORXED("IND"),PSORXED("FLD",128))=$P($G(^PSRX(PSORXED("IRXN"),"IND")),"^"),(PSORXED("INDF"),PSORXED("FLD",129))=$P($G(^PSRX(PSORXED("IRXN"),"IND")),"^",2)
  1. . S (PSORXED("INDO"),PSORXED("FLD",130))=$P($G(^PSRX(PSORXED("IRXN"),"IND")),"^",3)
  1. . D SIND^PSODIR(.PSORXED)
  1. INSQX ;
  1. K DIRUT,DUOUT,DTOUT,DIR,X,Y,DIC,DWPK,PSOOEINS,PSOOSINS,PSODELINS
  1. Q
  1. INIT ;setup psorenw array
  1. S PSORENW("RX0")=^PSRX(PSORENW("IRXN"),0),PSORENW("RX2")=^(2),PSORENW("RX3")=^(3),PSORENW("STA")=^("STA"),PSORENW("TN")=$G(^("TN"))
  1. S PSORENW("RX7")=$G(^PSRX(PSORENW("IRXN"),7)) ;p753
  1. I $G(PSOSIGFL),$G(PSORX("SIG"))]"" S PSORENW("SIG")=PSORX("SIG"),SIGOK=0
  1. E D
  1. .S PSORENW("IND")=$P($G(^("IND")),"^"),PSORENW("INDF")=$P($G(^("IND")),"^",2) ;*441-IND
  1. .I '$P($G(^PSRX(PSORENW("IRXN"),"SIG")),"^",2) S PSORENW("SIG")=$P($G(^("SIG")),"^")
  1. .E D
  1. ..S SIGOK=1 Q:$O(SIG(0))
  1. ..S D=0 F I=0:0 S D=D+1,I=$O(^PSRX(PSORENW("IRXN"),"SIG1",I)) Q:'I S SIG(D)=^PSRX(PSORENW("IRXN"),"SIG1",I,0)
  1. ..K PSOX1,D
  1. S PSORENW("OIRXN")=PSORENW("IRXN")
  1. S PSORENW("PROVIDER")=$S($G(PSORENW("PROVIDER")):PSORENW("PROVIDER"),1:$P(PSORENW("RX0"),"^",4))
  1. S (PSORENW("PROVIDER NAME"),PSORX("PROVIDER NAME"))=$P($G(^VA(200,PSORENW("PROVIDER"),0)),"^")
  1. ;*545 get dea#
  1. S PSORENW("DEA")=$S($L($G(PSORXED("DEACOPY"))):$G(PSORXED("DEACOPY")),1:$$RXDEA^PSOUTIL(PSORENW("IRXN")))
  1. I $P($G(^VA(200,PSORENW("PROVIDER"),"PS")),"^",7),$P($G(^("PS")),"^",8) S PSORENW("COSIGNING PROVIDER")=$P($G(^("PS")),"^",8)
  1. S PSORENW("CLINIC")=$S($G(PSORENW("CLINIC")):PSORENW("CLINIC"),1:$P(PSORENW("RX0"),"^",5))
  1. S PSORENW("REMARKS")="New Order Created by "_$S($G(COPY)&('$G(PSOEDIT)):"copying",1:"editing")_" Rx # "_$P(PSORENW("RX0"),"^")_"."
  1. S PSORENW("MAIL EXEMPTION")=$P(PSORENW("RX7"),"^",2) ;p753
  1. ;
  1. ; - Maintenance Dose Rx Remarks field
  1. I $G(PSOMTFLG) S PSORENW("REMARKS")="Maintenance Rx created from Titration Rx# "_$P(PSORENW("RX0"),"^")_"."
  1. ;
  1. S PSORENW("COSIGNER")=$S($G(PSORENW("COSIGNER")):PSORENW("COSIGNER"),$P(PSORENW("RX3"),"^",3):$P(PSORENW("RX3"),"^",3),1:"")
  1. K:PSORENW("COSIGNER")="" PSORENW("COSIGNER")
  1. S PSORENW("PSODFN")=$P(PSORENW("RX0"),"^",2)
  1. S PSORENW("ORX #")=$P(PSORENW("RX0"),"^")
  1. S:$G(PSODRUG("IEN")) PSORENW("DRUG IEN")=PSODRUG("IEN")
  1. ;; START NCC REMEDIATION >> 457*RJS - ADJUST MAX DAYS SUPPLY FOR 4 DAY SUPPLY
  1. I $$GET1^DIQ(50,+$G(PSODRUG("IEN")),17.5)="PSOCLO1",$P(PSORENW("RX0"),"^",8)<5 S PSORENW("DAYS SUPPLY")=$P(PSORENW("RX0"),"^",8)
  1. ;; END NCC REMEDIATION << 457*RJS
  1. ;*545 get detox #
  1. I $$DETOX^PSSOPKI($G(PSORENW("DRUG IEN"))) S PSORENW("DETX")=$$PRVDETOX^PSOUTIL(PSORENW("PROVIDER"))
  1. I $G(PSORENW("DAYS SUPPLY")) G QTY
  1. S PSORENW("DAYS SUPPLY")=$S($D(CLOZPAT):7,1:$P(PSORENW("RX0"),"^",8))
  1. QTY S PSORENW("QTY")=$S($G(PSORENW("QTY")):PSORENW("QTY"),1:$P(PSORENW("RX0"),"^",7))
  1. RFN S PSORENW("# OF REFILLS")=$S($D(CLOZPAT):0,$G(PSORENW("# OF REFILLS")):PSORENW("# OF REFILLS"),1:$P(PSORENW("RX0"),"^",9))
  1. S (PSOID,Y,PSORENW("FILL DATE"),PSORENW("ISSUE DATE"))=DT
  1. ;
  1. ; - Titration to Maintenance Rx
  1. I $G(PSOMTFLG) D
  1. . ; Copying ISSUE DATE from Titatrion Rx
  1. . S (PSOID,PSORENW("ISSUE DATE"))=$P(PSORENW("RX0"),"^",13)
  1. . ; Fill Date is set with Next Possible Fill from Titration Rx
  1. . I $P($G(PSORENW("RX3")),"^",2)>DT S PSORENW("FILL DATE")=$P(PSORENW("RX3"),"^",2)
  1. ;
  1. S:PSORENW("CLINIC") PSORX("CLINIC")=$P(^SC(+PSORENW("CLINIC"),0),"^")
  1. S PSORENW("PATIENT STATUS")=$S($G(PSORENW("PATIENT STATUS")):PSORENW("PATIENT STATUS"),'$P(PSORENW("RX0"),"^",3):$G(^PS(55,PSORENW("PSODFN"),"PS")),1:$P(PSORENW("RX0"),"^",3))
  1. S PSORENW("PTST NODE")=$G(^PS(53,PSORENW("PATIENT STATUS"),0))
  1. S PSDAYS=$S($G(PSORENW("DAYS SUPPLY")):PSORENW("DAYS SUPPLY"),'$P(PSORENW("RX0"),"^",8):$P(PSORENW("PTST NODE"),"^",3),1:$P(PSORENW("RX0"),"^",8))
  1. I $G(PSODRUG("IEN")) S DREN=PSODRUG("IEN"),POERR=1 D DRG^PSOORDRG K POERR
  1. D:$G(PSORENW("# OF REFILLS"))']"" RF
  1. ;
  1. ; - Maintenance Rx # of Refills adjustment
  1. I $G(PSOMTFLG),$G(PSORENW("# OF REFILLS"))>0 S PSORENW("# OF REFILLS")=PSORENW("# OF REFILLS")-1
  1. ;
  1. S PSORENW("MAIL/WINDOW")=$S($G(PSORENW("MAIL/WINDOW"))]"":PSORENW("MAIL/WINDOW"),1:$P(PSORENW("RX0"),"^",11))
  1. I PSORENW("MAIL/WINDOW")="P",$G(PSODRUG("DEA"))["D" S PSORENW("MAIL/WINDOW")="W" ;PAPI 441 - Make sure not Parked if DEA contains "D"
  1. S PSORX("MAIL/WINDOW")=$S(PSORENW("MAIL/WINDOW")="W":"WINDOW",PSORENW("MAIL/WINDOW")="P":"PARK",1:"MAIL") ;PAPI 441
  1. S PSORENW("COPIES")=$S($G(PSORENW("COPIES")):PSORENW("COPIES"),$P(PSORENW("RX0"),"^",18):$P(PSORENW("RX0"),"^",18),1:1)
  1. S PSORENW("CLERK CODE")=DUZ
  1. S:$G(PSORX("CLERK CODE"))']"" PSORX("CLERK CODE")=$P($G(^VA(200,DUZ,0)),"^")
  1. Q:$D(COPY) S PSORENW("ENT")=0
  1. K PSORENW("ENT") F I=0:0 S I=$O(PSORENW("DOSE",I)) Q:'I S PSORENW("ENT")=$G(PSORENW("ENT"))+1
  1. I $O(^TMP($J,"INS1",0)) D
  1. .K PSORXED("SIG"),DD
  1. .F I=0:0 S I=$O(^TMP($J,"INS1",I)) Q:'I S PSORENW("SIG",I)=^TMP($J,"INS1",I,0)
  1. .K ^TMP($J,"INS1")
  1. I $G(^PSRX(PSORENW("IRXN"),"INS"))]"" S PSORENW("INS")=^PSRX(PSORENW("IRXN"),"INS")
  1. I $G(^PSRX(PSORENW("IRXN"),"INSS"))]"" S PSORENW("SINS")=^PSRX(PSORENW("IRXN"),"INSS")
  1. I '$G(PSORENW("ENT")),'$G(PSOSIGFL) D DOLST1^PSOORED3(.PSORENW) S PSORENW("ENT")=+$G(OLENT)
  1. Q
  1. RF ;# of refills
  1. ; Retrieving the Maximum Number of Refills allowed
  1. S PSORENW("# OF REFILLS")=$$MAXNUMRF^PSOUTIL(+$G(PSODRUG("IEN")),PSDAYS,+$G(PSORENW("PATIENT STATUS")),.CLOZPAT)
  1. Q
  1. UPMI ;add dosing data for pre-poe rxs
  1. W !! K PSONEW("DFLG"),DIR,DIRUT,DTOUT,DUOUT S DIR(0)="Y",DIR("B")="No",DIR("A")="Dosing Instructions Are Missing!! Do You Want to Add Them"
  1. D ^DIR I 'Y!($D(DIRUT)) S QUIT=1 K DIR,DIRUT,DUOT,DUOUT Q
  1. S UPMI=1,EDTHLD=$G(PSORX("EDIT")) K PSORX("EDIT")
  1. D DOSE1^PSOORED5(.PSORXED) S (PSORXED,PSORX("EDIT"))=EDTHLD K EDTHLD I $G(PSONEW("DFLG")) S QUIT=1
  1. Q