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