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

PSOORED3.m

Go to the documentation of this file.
  1. PSOORED3 ;BIR/SAB-edit finished orders through backdoor ;Apr 08, 2020@09:09:53
  1. ;;7.0;OUTPATIENT PHARMACY;**46,78,99,117,133,148,249,251,379,378,372,416,313,444,402,515,574,441,725,744**;DEC 1997;Build 3
  1. ;External reference to PS(51.1 supported by DBIA 2225
  1. ;External reference to PS(51.2 supported by DBIA 2226
  1. ;called from psoored2
  1. D DOLST
  1. ;
  1. DOSE ;adds dosing info
  1. I '$G(PSORXED("ENT")) F S I=$O(PSORXED("DOSE",I)) Q:'I S PSORXED("ENT")=$G(PSORXED("ENT"))+1
  1. K ROU,UNITN,STRE,PSODOSE,RTE,NOUN,VERB M PSODOSE=PSORXED
  1. D KV K FIELD,DOSEOR,DOOR,X,Y,UNITS S ENT=1
  1. ASK S ROU="PSOORED3" D ASK^PSOBKDED K ROU I $G(JUMP) K JUMP G JUMP
  1. G:$D(DIRUT) EXQ
  1. I $G(QUIT)]"" K QUIT,ROU Q
  1. ;
  1. I $G(VERB)]"" S PSORXED("VERB",ENT)=VERB G DUPD
  1. VER D VER^PSOOREDX I X[U,$L(X)>1 S FIELD="VER" G JUMP
  1. G:$D(DTOUT)!($D(DUOUT)) EXQ
  1. I X="@" K PSORXED("VERB",ENT),VERB G DUPD
  1. S:X'="" (PSORXED("VERB",ENT),VERB)=X
  1. DUPD ;
  1. I $G(PSORXED("DOSE",ENT))'?.N&($G(PSORXED("DOSE",ENT))'?.N1".".N)!'DOSE("LD") K PSORXED("DOSE ORDERED",ENT),DUPD G NOU1
  1. D DUPD^PSOOREDX
  1. S DIR("B")=$S($G(PSORXED("DOSE ORDERED",ENT))]"":PSORXED("DOSE ORDERED",ENT),1:"") S:$E($G(DIR("B")),1)="." DIR("B")="0"_$G(DIR("B")) K:DIR("B")="" DIR("B")
  1. D ^DIR I X[U,$L(X)>1 S FIELD="DUPD" G JUMP
  1. G:$D(DTOUT)!($D(DUOUT)) EXQ
  1. I X="@"!(X=0) W !,"Dispense Units Per Dose is Required!!",! G DUPD
  1. D STR^PSOOREDX
  1. NOU1 G:'$G(PSORXED("DOSE ORDERED",ENT)) RTE
  1. D CNON
  1. N PSONDEF
  1. I $G(NOUN)]"" S PSORXED("NOUN",ENT)=NOUN
  1. NOU D NOU^PSOOREDX I X[U,$L(X)>1 S FIELD="NOU" G JUMP
  1. G:$D(DTOUT)!($D(DUOUT)) EXQ
  1. I X="@" K PSORXED("NOUN",ENT),NOUN G RTE
  1. I X'="",$G(PSONDEF)="" S NOUN=X
  1. I X'="",$G(PSONDEF)'=X S NOUN=X
  1. S:X'="" PSORXED("NOUN",ENT)=X
  1. RTE S:$G(PSORXED("ROUTE",ENT))']"" DRET=1
  1. K JUMP S ROU="PSOORED3" D RTE^PSOBKDED K ROU
  1. I $G(JUMP) K JUMP G JUMP
  1. G:$D(DTOUT)!($D(DUOUT)) EXQ
  1. I $G(QUIT) K QUIT,ROU Q
  1. ;
  1. SCH D SCH^PSOBKDED I X[U,$L(X)>1 S FIELD="SCH" G JUMP
  1. G:$D(DTOUT)!($D(DUOUT)) EXQ
  1. S SCH=$$SCHASL^PSOORED5(Y) D SCH^PSOSIG I $G(SCH)']""!($D(DTOUT))!($D(DUOUT)) G SCH
  1. S PSORXED("SCHEDULE",ENT)=SCH IF $G(SCHEX)'="" W " ("_SCHEX_")"
  1. K SCH,SCHEX,X,Y,PSOSCH
  1. S:$G(PSORXED("ENT"))<ENT PSORXED("ENT")=ENT
  1. ;
  1. DUR D KV K EXP
  1. ; PSO*7.0*574 - skip limited duration field for clozapine order
  1. I $P($G(^PSDRUG(PSODRUG("IEN"),"CLOZ1")),U)="PSOCLO1" G CON
  1. S DIR(0)="52.0113,4",DIR("A")="LIMITED DURATION (IN MONTHS, WEEKS, DAYS, HOURS OR MINUTES)"
  1. S DIR("B")=$S($G(DUR)]"":DUR,$G(PSORXED("DURATION",ENT))]"":PSORXED("DURATION",ENT),1:"") K:DIR("B")="" DIR("B")
  1. D ^DIR I X[U,$L(X)>1 S FIELD="DUR" G JUMP
  1. G:$D(DTOUT)!($D(DUOUT)) EXQ
  1. D DUR1^PSOOREDX
  1. ;
  1. CON D CON^PSOOREDX I X[U,$L(X)>1 S FIELD="CON" G JUMP
  1. G:$D(DTOUT)!($D(DUOUT)) EXQ
  1. I X="@",$G(PSORXED("CONJUNCTION",ENT))="" W !,?10,"Invalid Entry - nothing to delete!!" G CON
  1. S:X'=""&(X'="@") PSORXED("CONJUNCTION",ENT)=Y
  1. I X="@" D CON1^PSOOREDX G:$D(DTOUT)!$D(DUOUT) EXQ G:$D(DIRUT) MW G:'Y CON N CKX S CKX=1 D UPD^PSOOREDX G CON
  1. ;
  1. N PSODLBD4 S PSOSAVX=X,PSODLBD4=1
  1. I '$$DUROK(.PSORXED,ENT) D G DUR
  1. . W !!,"Duration is required for the dosage entered prior to the THEN conjunction.",$C(7),!
  1. I $G(PSORXED("CONJUNCTION",ENT))]"" S PSOCKCON=1 D DCHK1^PSODOSUT G:$G(PSORXED("DFLG"))!($G(PSORX("DFLG"))) MW S ENT=ENT+1 K DIR G ASK
  1. E K PSOCKCON I $$DCHK^PSODOSUT S PSOQUIT=1 G MW
  1. I PSOSAVX="",$G(PSORXED)!$D(PSOEDDOS) K PSOCKCON
  1. K PSOSAVX
  1. ;
  1. S DENT=$O(PSORXED("DOSE",ENT)) I DENT,(ENT+1)'=DENT D
  1. .K PSORXED("DOSE",DENT),PSORXED("NOUN",DENT),PSORXED("VERB",DENT),PSORXED("DOSE ORDERED",DENT),PSORXED("ROUTE",DENT),PSORXED("ODOSE",DENT)
  1. .K PSORXED("SCHEDULE",DENT),PSORXED("DURATION",DENT),PSORXED("CONJUNCTION",DENT),DENT
  1. I $G(FIELD)]"" K FIELD S QUIT=1
  1. I $O(^PSRX(PSORXED("IRXN"),"INS1",0)) D
  1. .F D=0:0 S D=$O(^PSRX(PSORXED("IRXN"),"INS1",D)) Q:'D S PSORXED("SIG",D)=^PSRX(PSORXED("IRXN"),"INS1",D,0)
  1. D EN^PSOFSIG(.PSORXED) D VER^PSOORED7:'$G(PSOVER) I $G(CKX),'$G(PSOSIGFL) D M1 K CKX
  1. S:'$D(PSORXED("DAYS SUPPLY")) PSORXED("DAYS SUPPLY")=$P(PSORXED("RX0"),"^",8)
  1. ; Checks if the current Days Supply value is greater than the Maximum Days Supply for the Drug, if so, reset
  1. D DAYSUP^PSOUTIL(+$G(PSODRUG("IEN")),.PSORXED,0)
  1. ;Needed to calculate QTY
  1. K QTY,QTYHLD S QTYHLD=$P(PSORXED("RX0"),"^",7) D QTY^PSOSIG(.PSORXED) I $G(PSORXED("QTY")) S QTY=1
  1. I $G(QTYHLD),'$G(PSORXED("QTY")) S PSORXED("QTY")=QTYHLD
  1. MW S PSOEXQ=0
  1. I $P($G(PSORXED("RX0")),U,11)="P",PSODRUG("DEA")["D" D G:PSOEXQ EXQ ;PAPI 441 - Ask for Mail/Window if needed
  1. .N PRKMW
  1. .D KV
  1. .W #,"This drug cannot be Parked! You must select a different routing!"
  1. .D MW^PSOPRK
  1. .I $G(DTOUT)!($G(DUOUT)) S PSOEXQ=1 Q
  1. .S PSORXED("MAIL/WINDOW")=PRKMW
  1. I $G(PSOSIGFL)=1 S PSORXED("ENT")=ENT,SIGOK=1 G EX1
  1. ;PSO*7*725 exit thru EX1 to kill vars
  1. K QTYHLD G:$G(PSOVER)!($G(PSOREEDQ)) EX1
  1. UDSIG I $O(SIG(0)) D
  1. .S D=0 F S D=$O(SIG(D)) Q:'D S ^PSRX(PSORXED("IRXN"),"SIG1",D,0)=SIG(D),$P(^PSRX(PSORXED("IRXN"),"SIG1",0),"^",3)=+$P($G(^PSRX(PSORXED("IRXN"),"SIG1",0)),"^",3)+1,$P(^(0),"^",4)=+$P($G(^(0)),"^",4)+1 Q:'$O(SIG(D))
  1. .S (A,I)=0 F S I=$O(^PSRX(PSORXED("IRXN"),"A",I)) Q:'I S A=A+1
  1. .D NOW^%DTC I $G(QTY) S A=A+1,^PSRX(PSORXED("IRXN"),"A",A,0)=%_"^E^"_DUZ_"^0^Quantity Updated "_"("_$P(^PSRX(PSORXED("IRXN"),0),"^",7)_")",$P(^PSRX(PSORXED("IRXN"),0),"^",7)=$G(PSORXED("QTY")) K QTY
  1. .S A=A+1,^PSRX(PSORXED("IRXN"),"A",A,0)=%_"^E^"_DUZ_"^0^New Dosing Instructions Added",^PSRX(PSORXED("IRXN"),"A",A,1)="ORIGINAL SIG^" D
  1. ..I '$P($G(^PSRX(PSORXED("IRXN"),"SIG")),"^",2) S $P(^PSRX(PSORXED("IRXN"),"A",A,1),"^",2)=$P($G(^PSRX(PSORXED("IRXN"),"SIG")),"^") Q
  1. ..F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),"SIG1",I)) Q:'I S ^PSRX(PSORXED("IRXN"),"A",A,2,I,0)=^PSRX(PSORXED("IRXN"),"SIG1",I,0),^PSRX(PSORXED("IRXN"),"A",A,2,0)="^52.34A^"_I_"^"_I
  1. .S ^PSRX(PSORXED("IRXN"),"SIG")="^1"
  1. .K SIG,A,I
  1. ;P744 Check if header exists, and check if header count matches entries
  1. S:'$D(^PSRX(PSORXED("IRXN"),"A",0)) ^PSRX(PSORXED("IRXN"),"A",0)="^52.3DA^"
  1. S COUNT="" S COUNT=$O(^PSRX(PSORXED("IRXN"),"A","Z"),-1)
  1. I $P(^PSRX(PSORXED("IRXN"),"A",0),"^",3)'=COUNT S ^PSRX(PSORXED("IRXN"),"A",0)="^52.3DA^"_COUNT_"^"_COUNT
  1. ;
  1. S ^PSRX(PSORXED("IRXN"),6,0)="^52.0113^"_ENT_"^"_ENT
  1. F I=1:1:ENT S ^PSRX(PSORXED("IRXN"),6,I,0)=PSORXED("DOSE",I)_"^"_$G(PSORXED("DOSE ORDERED",I))_"^"_$G(PSORXED("UNITS",I))_"^"_$G(PSORXED("NOUN",I))_"^" D
  1. .S ^PSRX(PSORXED("IRXN"),6,I,0)=^PSRX(PSORXED("IRXN"),6,I,0)_$G(PSORXED("DURATION",I))_"^"_$G(PSORXED("CONJUNCTION",I))_"^"_$G(PSORXED("ROUTE",I))_"^"_$G(PSORXED("SCHEDULE",I))_"^"_$G(PSORXED("VERB",I))
  1. .S ^PSRX(PSORXED("IRXN"),6,I,1)=$G(PSORXED("ODOSE",I))
  1. S ^PSRX(PSORXED("IRXN"),"POE")=1
  1. G EX
  1. Q
  1. EX ;
  1. K PSORXED("DOSE"),DOSE,DUPD,SCH,PSORXED("NOUN"),PSORXED("VERB"),VERB,NOUN,PSORXED("DOSE ORDERED"),DOSEOR,PSORXED("ROUTE"),ENT,PSORTE,SIG,PSODOSE
  1. K PSORXED("SCHEDULE"),PSORXED("DURATION"),PSORXED("CONJUNCTION"),DURA,X,Y,PSORXED("ODOSE")
  1. EX1 K STRE,UNITN,DOSE,DUPD,SCH,VERB,NOUN,DOSEOR,RTE,DUR,X,Y,ENTS,PSOSCH,ERTE,ROU,PSOEXQ
  1. KV K DIR,DIRUT,DUOUT,DTOUT
  1. Q
  1. EXQ K PSORXED,PSOSIGFL M PSORXED=PSODOSE D EN^PSOFSIG(.PSORXED) S PSORXED("DFLG")=1 D M1 G EX
  1. Q
  1. M1 D M1^PSOOREDX
  1. Q
  1. DOLST1(PSORXED) ;
  1. ;
  1. DOLST F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),6,I)) Q:'I S INST=^(I,0) D
  1. .S PSORXED("DOSE",I)=$P(INST,"^"),PSORXED("DOSE ORDERED",I)=$P(INST,"^",2),PSORXED("UNITS",I)=$P(INST,"^",3),PSORXED("NOUN",I)=$P(INST,"^",4)
  1. .I $P(INST,"^",5)]"" D
  1. ..S PSORXED("DURATION",I)=$S($E($P(INST,"^",5),1)'?.N:$E($P(INST,"^",5),2,99)_$E($P(INST,"^",5),1),1:$P(INST,"^",5))
  1. .S PSORXED("ROUTE",I)=$P(INST,"^",7),PSORXED("SCHEDULE",I)=$P(INST,"^",8)
  1. .S PSORXED("CONJUNCTION",I)=$P(INST,"^",6),PSORXED("VERB",I)=$P(INST,"^",9),OLENT=I
  1. .S PSORXED("ODOSE",I)=$G(^PSRX(PSORXED("IRXN"),6,I,1))
  1. K:'$O(PSORXED("DOSE",0)) PSORXED("ENT"),OLENT
  1. S PSORXED("INS")=$G(^PSRX(PSORXED("IRXN"),"INS"))
  1. S PSORXED("IND")=$P($G(^PSRX(PSORXED("IRXN"),"IND")),"^"),PSORXED("INDF")=$P($G(^PSRX(PSORXED("IRXN"),"IND")),"^",2) ;441-IND
  1. Q
  1. UPDSIG ;updates sig
  1. K ^PSRX(PSORXED("IRXN"),"SIG1") S ^PSRX(PSORXED("IRXN"),"SIG1",0)="^52.04A^^"
  1. S D=0 F S D=$O(SIG(D)) Q:'D S ^PSRX(PSORXED("IRXN"),"SIG1",D,0)=SIG(D),$P(^PSRX(PSORXED("IRXN"),"SIG1",0),"^",3)=+$P($G(^PSRX(PSORXED("IRXN"),"SIG1",0)),"^",3)+1,$P(^(0),"^",4)=+$P($G(^(0)),"^",4)+1
  1. S ^PSRX(PSORXED("IRXN"),"SIG")="^1"
  1. Q
  1. JUMP ;jump to fields
  1. I $L($E(X,2,99))<3 W !,"Field Name Must Be At Least 3 Characters in Length",! G @FIELD
  1. D FNM^PSOOREDX
  1. I FLDNM']"" K X,NM,FLDNM W !,"INVALID FIELD NAME. PLEASE TRY AGAIN!",! G @FIELD
  1. F AR=1:1:PSORXED("ENT") W !,AR_". "_$P(FLDNM,"^",2)_": "_$S(NM="ROU"&($G(PSORXED($P(FLDNM,"^"),AR))):$P(^PS(51.2,PSORXED($P(FLDNM,"^"),AR),0),"^"),1:$G(PSORXED($P(FLDNM,"^"),AR))) S AR1=AR
  1. D KV S DIR("A",1)="* Indicates which fields will create a New Order",DIR("A")="Select Field to Edit by number",DIR(0)="NO^1:"_AR1 D ^DIR G:$D(DIRUT) @FIELD
  1. D JFN^PSOOREDX G:FLDNM="" @FIELD G @FLDNM
  1. G EX
  1. Q
  1. ;
  1. CNON ;
  1. I $G(NOUN)'="" Q
  1. I '$G(PSORXED("DOSE ORDERED",ENT)) Q
  1. N PSONLT,PSONLL,PSONLG
  1. S PSONLL=$P($G(DOSE("DD",+$G(PSODRUG("IEN")))),"^",9) I PSONLL="" Q
  1. S PSONLG=$L(PSONLL)
  1. I PSONLG'>3 Q
  1. S PSONLT=$E(PSONLL,(PSONLG-2),PSONLG)
  1. I PSONLT'="(S)",PSONLT'="(s)" Q
  1. ;test noun of (S)
  1. K NOUN ; NOT SURE ABOUT THIS???
  1. I $G(PSORXED("DOSE ORDERED",ENT))>1 S PSORXED("NOUN",ENT)=$E(PSONLL,1,(PSONLG-3))_$E(PSONLT,2) Q
  1. S PSORXED("NOUN",ENT)=$E(PSONLL,1,(PSONLG-3))
  1. Q
  1. ;
  1. DUROK(DOSE,ENT) ; Duration OK? (Complex Doses only)
  1. ;Input: PSORXED - array with doses
  1. ; ENT - dose entry in the PSORXED array
  1. ;Output: 1: Duration OK / 0: Duration not OK (required, but missing)
  1. N SCHIEN
  1. I $G(DOSE("CONJUNCTION",ENT))'="T" Q 1
  1. I $G(DOSE("DURATION",ENT)) Q 1
  1. I $G(DOSE("SCHEDULE",ENT))="" Q 1
  1. S SCHIEN=$O(^PS(51.1,"B",$G(DOSE("SCHEDULE",ENT)),0))
  1. I $$GET1^DIQ(51.1,SCHIEN,5,"I")="O" Q 1
  1. Q 0