ORCMED.m

ORCMED ;SLC/MKB - MEDICATION ACTIONS ;11/07/13  11:07

 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,7,38,48,94,141,178,190,195,243,306,371,380,383,311,381**;Dec 17, 1997;Build 8

XFER ; -- transfer to in/outpt medsx

 N ORPTLK,ORTYPE,ORXFER,ORSRC,ORCAT,OREVENT,X,ORINPT,ORIDLG,ORODLG,ORIVDLG,ORNMSP,ORCNT,ORI,NMBR,ORIFN,OLDIFN,ORDIALOG,ORDG,ORCHECK,ORQUIT,ORDUZ,ORLOG,FIRST,ORDITM,ORD,ORERR

 S ORPTLK=$$LOCK^ORX2(+ORVP) I 'ORPTLK D  G XFQ ; lock pt chart

 . W !!,$C(7),$P(ORPTLK,U,2) H 2

 . S:'$D(VALMBCK) VALMBCK=""

 I '$G(ORNMBR) S ORNMBR=$$ORDERS^ORCHART("transfer") G:'ORNMBR XFQ

 D FULL^VALM1 S VALMBCK="R",ORTYPE="Q",ORXFER=1,ORDUZ=DUZ,ORSRC="X"

 S X=$P($P($G(^TMP("OR",$J,"CURRENT",0)),U,3),";",3) S:X="" X=$G(ORWARD)

 S ORCAT=$S(X:"O",1:"I") I ORCAT="I"!$G(ORWARD) D  Q:$G(OREVENT)="^"

 . W !!,$$CURRENT^OREVNT

 . S X=$$DELAY^ORCACT I X="^" S OREVENT="^" Q

 . S:X OREVENT=+$$PTEVENT^OREVNT(+ORVP,1)

 I '$G(ORL) S ORL=$S($G(OREVENT):$$LOC^OREVNTX(OREVENT),1:$$LOCATION^ORCMENU1) G:ORL="^" XFQ

 S ORINPT=$$INPT^ORCD,ORNP=$$PROVIDER^ORCMENU1 G:ORNP="^" XFQ

 I 'ORINPT,ORCAT="I" D IMOLOC^ORIMO(.ORINPT,+ORL,+ORVP) S:ORINPT<0 ORINPT=0 ;allow inpt meds at this location?

 S ORIDLG=+$O(^ORD(101.41,"AB","PSJ OR PAT OE",0))

 S ORODLG=+$O(^ORD(101.41,"AB","PSO OERR",0))

 S ORIVDLG=+$O(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0))

 D PROVIDER^ORCDPSIV G:$G(ORQUIT) XFQ ;X:$D(^ORD(101.41,ORDIALOG,3)) ^(3)

 S ORNMSP="PS" D DISPLAY^ORCHECK

 S ORCNT=$L(ORNMBR,",") S:$P(ORNMBR,",",ORCNT)'>0 ORCNT=ORCNT-1

XF1 F ORI=1:1:ORCNT S NMBR=$P(ORNMBR,",",ORI) D:NMBR  I $D(ORQUIT),ORI<ORCNT Q:'$$CONT  ;if not last one, ask

 . K ORIFN,ORDIALOG,ORDG,ORDOSE,ORCHECK,ORQUIT,ORERR

 . K ^TMP("PSJMR",$J),^TMP("ORWORD",$J),^TMP("ORSIG",$J)

 . S OLDIFN=+$P($G(^TMP("OR",$J,ORTAB,"IDX",NMBR)),U,4)

 . S ORDITM=$$ORDITEM^ORCACT(OLDIFN) D SUBHDR^ORCACT(ORDITM)

 . I '$$VALID^ORCACT0(OLDIFN,"XFR",.ORERR) W !,ORERR H 2 Q

 . S ORD=$P($G(^OR(100,OLDIFN,0)),U,5) Q:ORD'["101.41"  ;error msg?

 . S ORDIALOG=$S(+ORD=ORIVDLG:ORIVDLG,ORCAT="I":ORIDLG,1:ORODLG)

 . S ORDG=+$P($G(^ORD(101.41,ORDIALOG,0)),U,5)

 . D GETDLG^ORCD(ORDIALOG),GETORDER^ORCD(OLDIFN)

 . I ORDIALOG'=ORIVDLG D OUT:ORCAT="I",IN:ORCAT="O" ;convert data

 . K ORDIALOG($$PTR^ORCD("OR GTX START DATE/TIME"),1)

 . K ORDIALOG($$PTR^ORCD("OR GTX NOW"),1)

 . S ORLOG=+$E($$NOW^XLFDT,1,12),FIRST=1

XF2 . D DIALOG^ORCDLG Q:$G(ORQUIT)&FIRST  K ORQUIT

 . D ACCEPT^ORCHECK(),DISPLAY^ORCDLG S X=$$OK^ORCDLG I X="^" S ORQUIT=1 Q

 . I X="E" K ORCHECK S FIRST=0 G XF2

 . I X="C" W !?10,"... order cancelled.",! Q

 . I X="P" D

 . . D EN^ORCSAVE W !?10,$S(ORIFN:"... order placed.",1:"ERROR"),!

 . . S:$G(ORIFN) ^TMP("ORNEW",$J,ORIFN,1)=""

 . . I '$D(^TMP("ORECALL",$J,ORDIALOG)) M ^(ORDIALOG)=ORDIALOG M:$D(^TMP("ORWORD",$J)) ^TMP("ORECALL",$J,ORDIALOG)=^TMP("ORWORD",$J) ;save 1st values

XFQ D EXIT^ORCDPS1 ;X:$D(^ORD(101.41,ORDIALOG,4)) ^(4)

 K ^TMP("ORWORD",$J),^TMP("ORSIG",$J)

 D:'$D(^TMP("ORNEW",$J)) UNLOCK^ORX2(+ORVP) ;unlock if no new orders

 Q

 ;

IN ; -- Kill extra values, Reset ID's/DD from Inpt dialog

 N ORD1,ORDLI,ORDFIN,ORDCNT,ORDORIG,ORDORIGF,P,ORDD,INSTR,ORDE

 F P="START DATE/TIME","NOW" K ORDIALOG($$PTR(P),1)

 S ORD1=$P($G(ORDIALOG($$PTR("DOSE"),1)),"&",5)

 S ORDORIG=ORDIALOG($$PTR("INSTRUCTIONS"),1)

 S ORDD=$G(ORDIALOG($$PTR("DISPENSE DRUG"),1))

 S INSTR=$$PTR("INSTRUCTIONS"),ORDE=$D(ORDIALOG($$PTR("DOSE"),1))

 D DOSES("O")

 I ORDE=1,($D(ORDIALOG($$PTR("DOSE"),0))'=1) D  Q

 .;corresponding dosage deleted, wipe the instructions

 .S ORDIALOG(INSTR,1)=""

 S ORDFIN="",ORDCNT=0,ORDORIGF=0

 ;look in the new instructions list for the original inpatient instructions and the dose

 I $L(ORD1) D

 .S ORDLI=0 F  S ORDLI=$O(ORDIALOG(INSTR,"LIST",ORDLI)) Q:'ORDLI  D

 ..I $P(ORDIALOG(INSTR,"LIST",ORDLI),U)=ORDORIG S ORDORIGF=1

 .;look in the returned doses for the local possible dose

 I '$L(ORD1) D

 .S ORDOSE=0 F  S ORDOSE=$O(ORDOSE(ORDOSE)) Q:'ORDOSE  D

 ..I $P(ORDOSE(ORDOSE),U,5)=ORDORIG,($P(ORDOSE(ORDOSE),U,6)=ORDD) S ORDFIN=$P(ORDIALOG(INSTR,"LIST",ORDOSE),U),ORDCNT=ORDCNT+1

 ;If there was a dose string and original instructions are not in the new instructions list then replace the instructions

 I ORDE=1,(ORDORIGF=0) D

 .I ORDCNT=1 S ORDIALOG(INSTR,1)=ORDFIN ;only one item in the list found containing the dose string - set the instructions to the item found

 .I ORDCNT'=1 S ORDIALOG(INSTR,1)="" ;no items or more than one item in the list found containing the dose string - blank the instructions

 Q

 ;

OUT ; -- Kill extra values, Reset ID's/DD from Outpt dialog

 N ORD1,ORDLI,ORDFIN,ORDCNT,ORDORIG,ORDORIGF,INSTR,I,ORDD,ORDE

 S ORDD=$G(ORDIALOG($$PTR("DISPENSE DRUG"),1))

 S INSTR=$$PTR("INSTRUCTIONS"),I=0 F  S I=$O(ORDIALOG(INSTR,I)) Q:'I  S ORDE(I)=$D(ORDIALOG($$PTR("DOSE"),I))

 D DOSES("I")

 ;quit if a complex order

 I $D(ORDIALOG($$PTR^ORCMED("AND/THEN"),1)) Q

 S I=0 F  S I=$O(ORDIALOG(INSTR,I)) Q:'I  D

 .I ORDE(I)=1,($D(ORDIALOG($$PTR("DOSE"),I))'=1) D  Q

 ..;corresponding dosage deleted, wipe the instructions

 ..S ORDIALOG(INSTR,I)=""

 .S ORD1=$P($G(ORDIALOG($$PTR("DOSE"),I)),"&",5)

 .S ORDORIG=ORDIALOG(INSTR,I)

 .N P I '$O(ORDIALOG(INSTR,0)) D  ;old sig in comments

 .. N WP S WP=$$PTR("WORD PROCESSING 1") K ^TMP("ORSIG",$J)

 .. M ^TMP("ORSIG",$J)=^TMP("ORWORD",$J,WP,1)

 .. K ORDIALOG(WP,1),^TMP("ORWORD",$J,WP,1)

 .F P="PATIENT INSTRUCTIONS","START DATE/TIME","DAYS SUPPLY","QUANTITY","REFILLS","ROUTING","SERVICE CONNECTED" K ORDIALOG($$PTR(P),I)

 .I $G(ORDIALOG($$PTR("URGENCY"),I))=99 K ORDIALOG($$PTR("URGENCY"),I)

 .S ORDFIN="",ORDCNT=0,ORDORIGF=0

 .;look in the new instructions list for the original instructions and the possible dose

 .I $L(ORD1) D

 ..S ORDLI=0 F  S ORDLI=$O(ORDIALOG(INSTR,"LIST",ORDLI)) Q:'ORDLI  D

 ...I $P(ORDIALOG(INSTR,"LIST",ORDLI),U)=ORDORIG S ORDORIGF=1

 .;look in the returned doses for the local possible dose

 .I '$L(ORD1) D

 ..S ORDOSE=0 F  S ORDOSE=$O(ORDOSE(ORDOSE)) Q:'ORDOSE  D

 ...I $P(ORDOSE(ORDOSE),U,5)=ORDORIG,($P(ORDOSE(ORDOSE),U,6)=ORDD) S ORDFIN=$P(ORDIALOG(INSTR,"LIST",ORDOSE),U),ORDCNT=ORDCNT+1

 .;If there was a dose string and original instructions are not in the new instructions list then replace the instructions

 .I ORDE(I)=1,(ORDORIGF=0) D

 ..I ORDCNT=1 S ORDIALOG(INSTR,I)=ORDFIN ;only one item in the list found containing the dose string - set the instructions to the item found

 ..I ORDCNT'=1 S ORDIALOG(INSTR,I)="" ;no items or more than one item in the list found containing the dose string - blank the instructions

 Q

 ;

DOSES(TYPE)     ; -- Convert doses to new TYPE, reset ID strings

 N PSOI,ORMED,PROMPT,DOSE,DRUG,I,X,DD,DRUG0,STR

 F I="DISPENSE DRUG","STRENGTH","DRUG NAME","SIG" K ORDIALOG($$PTR(I),1)

 S PSOI=+$P($G(^ORD(101.43,+$G(ORDIALOG($$PTR("ORDERABLE ITEM"),1)),0)),U,2),ORMED=$P($G(^(0)),U)

 D DOSE^PSSORUTL(.ORDOSE,PSOI,TYPE,+ORVP) I $G(ORDOSE(1))=-1 K ORDOSE

 S PROMPT=$$PTR("INSTRUCTIONS"),DOSE=$$PTR("DOSE")

 S DRUG=$$PTR("DISPENSE DRUG") D D1^ORCDPS2

 S I=0 F  S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0  D

 . K ORDIALOG(DOSE,I) S X=$G(ORDIALOG(PROMPT,I)) Q:'$L(X)

 . S X=$$UP^XLFSTR(X),DD=+$G(ORDIALOG(PROMPT,"LIST","D",X)) Q:'DD

 . S ORDIALOG(DOSE,I)=$TR($G(ORDOSE("DD",DD,X)),"^","&")

 . S ORDIALOG(DRUG,I)=DD,DRUG0=$G(ORDOSE("DD",DD))

 . S STR=$P(DRUG0,U,5)_$P(DRUG0,U,6)

 . I STR'>0 S:'$G(ORDOSE(1)) ORDIALOG($$PTR("DRUG NAME"),1)=$P(DRUG0,U) Q

 . I ORMED'[STR,TYPE="O"!'$G(ORDOSE(1)) S ORDIALOG($$PTR("STRENGTH"),1)=STR

 Q

 ;

CONT() ; -- Want to continue processing orders?

 N X,Y,DIR

 S DIR(0)="YA",DIR("A")="Do you want to continue transferring orders? ",DIR("B")="YES"

 S DIR("?")="Enter YES to continue transferring the remaining orders selected, or NO to quit this option."

 D ^DIR

 Q +Y

 ;

SHOWSIG ; -- Show old sig for transfer in ^TMP("ORSIG",$J)

 N ORTX,I,X,ORMAX S ORMAX=72

 S I=0 F  S I=$O(^TMP("ORSIG",$J,I)) Q:I'>0  S X=$G(^(I,0)) D:$L(X) TXT^ORCHTAB

 S I=0 F  S I=$O(ORTX(I)) Q:I'>0  W !,$S(I=1:"(Sig: ",1:"      ")_ORTX(I)

 W ")"

 Q

 ;

PTR(NAME) ; -- Returns pointer to OR GTX NAME

 Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0))

 ;

REFILLS ; -- Request a refill for med orders

 ;    ORNMBR = #,#,...,# of selected orders

 ;

 N ORLK,ORI,NMBR,IDX,ORIFN,ORDITM,ORERR,ORQUIT,OROUT

 I '$G(ORNMBR) S ORNMBR=$$ORDERS^ORCHART("") G:'ORNMBR RFQ

 D FREEZE^ORCMENU S VALMBCK="R"

 S ORNP=$$PROVIDER^ORCMENU1 G:ORNP="^" RFQ

 S:'$G(ORL) ORL=$$LOCATION^ORCMENU1 G:ORL="^" RFQ

 S OROUT=$$ROUTING G:OROUT="^" RFQ

 F ORI=1:1:$L(ORNMBR,",") S NMBR=$P(ORNMBR,",",ORI) D:NMBR  Q:$D(ORQUIT)

 . S IDX=$G(^TMP("OR",$J,"CURRENT","IDX",NMBR)),ORIFN=+$P(IDX,U,4)

 . Q:'ORIFN  I '$D(^OR(100,ORIFN,0)) W !,"Invalid order number!" H 2 Q

 . S ORDITM=$$ORDITEM^ORCACT(ORIFN) D SUBHDR^ORCACT(ORDITM)

 . I '$$VALID^ORCACT0(ORIFN,"RF",.ORERR) W !,ORERR H 2 Q

 . S ORLK=$$LOCK1^ORX2(+ORIFN) I 'ORLK W !,$P(ORLK,U,2) H 2 Q

 . D REF^ORMBLDPS(ORIFN,OROUT),UNLK1^ORX2(+ORIFN)

 . W !?10,"... refill requested.",$$RETURN

RFQ Q

 ;

RETURN() ; -- press return to cont

 N X W !,"Press <return> to continue ..." R X:DTIME

 Q ""

 ;

ROUTING() ; -- Routing for refill

 N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT S DIR(0)="SAM^W:WINDOW;M:MAIL;C:ADMINISTERED IN CLINIC;"

 S DIR("A")="Routing: ",DIR("B")=$S($D(^PSX(550,"C")):"MAIL",1:"WINDOW")

 S DIR("?")="Select how the patient is to receive this refill, by mail or at the window or in the clinic"

 D ^DIR S:$D(DTOUT)!(X["^") Y="^"

 Q Y

 ;

NW ; -- Order New Medication from Meds tab

 ;    Requires ORDIALOG      = name of pkg dialog

 ;             OREVENT       = event, if delaying orders

 ;             OREVENT("TS") = treating spec, if admission or transfer

 N ORPTLK G:'$L($G(ORDIALOG)) NWQ

 S ORPTLK=$$LOCK^ORX2(+ORVP) I 'ORPTLK W !!,$C(7),$P(ORPTLK,U,2) H 2 Q

 D FREEZE^ORCMENU S VALMBCK="R"

 S ORNP=$$PROVIDER^ORCMENU1 G:ORNP="^" NWQ

 I '$G(ORL) S ORL=$S($G(OREVENT):$$LOC^OREVNTX(OREVENT),1:$$LOCATION^ORCMENU1) G:ORL["^" NWQ

 S ORDIALOG=$O(^ORD(101.41,"AB",$E(ORDIALOG,1,63),0)) G:'ORDIALOG NWQ

 D ADD^ORCDLG,REBLD^ORCMENU:$D(^TMP("ORNEW",$J))

 K ORDIALOG,^TMP("ORWORD",$J),^TMP("ORECALL",$J) S VALMBCK="R"

NWQ D:'$D(^TMP("ORNEW",$J)) UNLOCK^ORX2(+ORVP) ;unlock if no new orders

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---ORCMED   10240     printed  Feb 18, 2025@23:55:06                                                                                                                                                                                                     Page 2

ORCMED    ;SLC/MKB - MEDICATION ACTIONS ;11/07/13  11:07

 +1       ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,7,38,48,94,141,178,190,195,243,306,371,380,383,311,381**;Dec 17, 1997;Build 8

XFER      ; -- transfer to in/outpt medsx

 +1        NEW ORPTLK,ORTYPE,ORXFER,ORSRC,ORCAT,OREVENT,X,ORINPT,ORIDLG,ORODLG,ORIVDLG,ORNMSP,ORCNT,ORI,NMBR,ORIFN,OLDIFN,ORDIALOG,ORDG,ORCHECK,ORQUIT,ORDUZ,ORLOG,FIRST,ORDITM,ORD,ORERR

 +2       ; lock pt chart

           SET ORPTLK=$$LOCK^ORX2(+ORVP)

           IF 'ORPTLK

               Begin DoDot:1

 +3                WRITE !!,$CHAR(7),$PIECE(ORPTLK,U,2)

                   HANG 2

 +4                if '$DATA(VALMBCK)

                       SET VALMBCK=""

               End DoDot:1

               GOTO XFQ

 +5        IF '$GET(ORNMBR)

               SET ORNMBR=$$ORDERS^ORCHART("transfer")

               if 'ORNMBR

                   GOTO XFQ

 +6        DO FULL^VALM1

           SET VALMBCK="R"

           SET ORTYPE="Q"

           SET ORXFER=1

           SET ORDUZ=DUZ

           SET ORSRC="X"

 +7        SET X=$PIECE($PIECE($GET(^TMP("OR",$JOB,"CURRENT",0)),U,3),";",3)

           if X=""

               SET X=$GET(ORWARD)

 +8        SET ORCAT=$SELECT(X:"O",1:"I")

           IF ORCAT="I"!$GET(ORWARD)

               Begin DoDot:1

 +9                WRITE !!,$$CURRENT^OREVNT

 +10               SET X=$$DELAY^ORCACT

                   IF X="^"

                       SET OREVENT="^"

                       QUIT 

 +11               if X

                       SET OREVENT=+$$PTEVENT^OREVNT(+ORVP,1)

               End DoDot:1

               if $GET(OREVENT)="^"

                   QUIT 

 +12       IF '$GET(ORL)

               SET ORL=$SELECT($GET(OREVENT):$$LOC^OREVNTX(OREVENT),1:$$LOCATION^ORCMENU1)

               if ORL="^"

                   GOTO XFQ

 +13       SET ORINPT=$$INPT^ORCD

           SET ORNP=$$PROVIDER^ORCMENU1

           if ORNP="^"

               GOTO XFQ

 +14      ;allow inpt meds at this location?

           IF 'ORINPT

               IF ORCAT="I"

                   DO IMOLOC^ORIMO(.ORINPT,+ORL,+ORVP)

                   if ORINPT<0

                       SET ORINPT=0

 +15       SET ORIDLG=+$ORDER(^ORD(101.41,"AB","PSJ OR PAT OE",0))

 +16       SET ORODLG=+$ORDER(^ORD(101.41,"AB","PSO OERR",0))

 +17       SET ORIVDLG=+$ORDER(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0))

 +18      ;X:$D(^ORD(101.41,ORDIALOG,3)) ^(3)

           DO PROVIDER^ORCDPSIV

           if $GET(ORQUIT)

               GOTO XFQ

 +19       SET ORNMSP="PS"

           DO DISPLAY^ORCHECK

 +20       SET ORCNT=$LENGTH(ORNMBR,",")

           if $PIECE(ORNMBR,",",ORCNT)'>0

               SET ORCNT=ORCNT-1

XF1       ;if not last one, ask

           FOR ORI=1:1:ORCNT

               SET NMBR=$PIECE(ORNMBR,",",ORI)

               if NMBR

                   Begin DoDot:1

 +1                    KILL ORIFN,ORDIALOG,ORDG,ORDOSE,ORCHECK,ORQUIT,ORERR

 +2                    KILL ^TMP("PSJMR",$JOB),^TMP("ORWORD",$JOB),^TMP("ORSIG",$JOB)

 +3                    SET OLDIFN=+$PIECE($GET(^TMP("OR",$JOB,ORTAB,"IDX",NMBR)),U,4)

 +4                    SET ORDITM=$$ORDITEM^ORCACT(OLDIFN)

                       DO SUBHDR^ORCACT(ORDITM)

 +5                    IF '$$VALID^ORCACT0(OLDIFN,"XFR",.ORERR)

                           WRITE !,ORERR

                           HANG 2

                           QUIT 

 +6       ;error msg?

                       SET ORD=$PIECE($GET(^OR(100,OLDIFN,0)),U,5)

                       if ORD'["101.41"

                           QUIT 

 +7                    SET ORDIALOG=$SELECT(+ORD=ORIVDLG:ORIVDLG,ORCAT="I":ORIDLG,1:ORODLG)

 +8                    SET ORDG=+$PIECE($GET(^ORD(101.41,ORDIALOG,0)),U,5)

 +9                    DO GETDLG^ORCD(ORDIALOG)

                       DO GETORDER^ORCD(OLDIFN)

 +10      ;convert data

                       IF ORDIALOG'=ORIVDLG

                           if ORCAT="I"

                               DO OUT

                           if ORCAT="O"

                               DO IN

 +11                   KILL ORDIALOG($$PTR^ORCD("OR GTX START DATE/TIME"),1)

 +12                   KILL ORDIALOG($$PTR^ORCD("OR GTX NOW"),1)

 +13                   SET ORLOG=+$EXTRACT($$NOW^XLFDT,1,12)

                       SET FIRST=1

XF2                    DO DIALOG^ORCDLG

                       if $GET(ORQUIT)&FIRST

                           QUIT 

                       KILL ORQUIT

 +1                    DO ACCEPT^ORCHECK()

                       DO DISPLAY^ORCDLG

                       SET X=$$OK^ORCDLG

                       IF X="^"

                           SET ORQUIT=1

                           QUIT 

 +2                    IF X="E"

                           KILL ORCHECK

                           SET FIRST=0

                           GOTO XF2

 +3                    IF X="C"

                           WRITE !?10,"... order cancelled.",!

                           QUIT 

 +4                    IF X="P"

                           Begin DoDot:2

 +5                            DO EN^ORCSAVE

                               WRITE !?10,$SELECT(ORIFN:"... order placed.",1:"ERROR"),!

 +6                            if $GET(ORIFN)

                                   SET ^TMP("ORNEW",$JOB,ORIFN,1)=""

 +7       ;save 1st values

                               IF '$DATA(^TMP("ORECALL",$JOB,ORDIALOG))

                                   MERGE ^(ORDIALOG)=ORDIALOG

                                   if $DATA(^TMP("ORWORD",$JOB))

                                       MERGE ^TMP("ORECALL",$JOB,ORDIALOG)=^TMP("ORWORD",$JOB)

                           End DoDot:2

                   End DoDot:1

               IF $DATA(ORQUIT)

                   IF ORI<ORCNT

                       if '$$CONT

                           QUIT 

XFQ       ;X:$D(^ORD(101.41,ORDIALOG,4)) ^(4)

           DO EXIT^ORCDPS1

 +1        KILL ^TMP("ORWORD",$JOB),^TMP("ORSIG",$JOB)

 +2       ;unlock if no new orders

           if '$DATA(^TMP("ORNEW",$JOB))

               DO UNLOCK^ORX2(+ORVP)

 +3        QUIT 

 +4       ;

IN        ; -- Kill extra values, Reset ID's/DD from Inpt dialog

 +1        NEW ORD1,ORDLI,ORDFIN,ORDCNT,ORDORIG,ORDORIGF,P,ORDD,INSTR,ORDE

 +2        FOR P="START DATE/TIME","NOW"

               KILL ORDIALOG($$PTR(P),1)

 +3        SET ORD1=$PIECE($GET(ORDIALOG($$PTR("DOSE"),1)),"&",5)

 +4        SET ORDORIG=ORDIALOG($$PTR("INSTRUCTIONS"),1)

 +5        SET ORDD=$GET(ORDIALOG($$PTR("DISPENSE DRUG"),1))

 +6        SET INSTR=$$PTR("INSTRUCTIONS")

           SET ORDE=$DATA(ORDIALOG($$PTR("DOSE"),1))

 +7        DO DOSES("O")

 +8        IF ORDE=1

               IF ($DATA(ORDIALOG($$PTR("DOSE"),0))'=1)

                   Begin DoDot:1

 +9       ;corresponding dosage deleted, wipe the instructions

 +10                   SET ORDIALOG(INSTR,1)=""

                   End DoDot:1

                   QUIT 

 +11       SET ORDFIN=""

           SET ORDCNT=0

           SET ORDORIGF=0

 +12      ;look in the new instructions list for the original inpatient instructions and the dose

 +13       IF $LENGTH(ORD1)

               Begin DoDot:1

 +14               SET ORDLI=0

                   FOR 

                       SET ORDLI=$ORDER(ORDIALOG(INSTR,"LIST",ORDLI))

                       if 'ORDLI

                           QUIT 

                       Begin DoDot:2

 +15                       IF $PIECE(ORDIALOG(INSTR,"LIST",ORDLI),U)=ORDORIG

                               SET ORDORIGF=1

                       End DoDot:2

 +16      ;look in the returned doses for the local possible dose

               End DoDot:1

 +17       IF '$LENGTH(ORD1)

               Begin DoDot:1

 +18               SET ORDOSE=0

                   FOR 

                       SET ORDOSE=$ORDER(ORDOSE(ORDOSE))

                       if 'ORDOSE

                           QUIT 

                       Begin DoDot:2

 +19                       IF $PIECE(ORDOSE(ORDOSE),U,5)=ORDORIG

                               IF ($PIECE(ORDOSE(ORDOSE),U,6)=ORDD)

                                   SET ORDFIN=$PIECE(ORDIALOG(INSTR,"LIST",ORDOSE),U)

                                   SET ORDCNT=ORDCNT+1

                       End DoDot:2

               End DoDot:1

 +20      ;If there was a dose string and original instructions are not in the new instructions list then replace the instructions

 +21       IF ORDE=1

               IF (ORDORIGF=0)

                   Begin DoDot:1

 +22      ;only one item in the list found containing the dose string - set the instructions to the item found

                       IF ORDCNT=1

                           SET ORDIALOG(INSTR,1)=ORDFIN

 +23      ;no items or more than one item in the list found containing the dose string - blank the instructions

                       IF ORDCNT'=1

                           SET ORDIALOG(INSTR,1)=""

                   End DoDot:1

 +24       QUIT 

 +25      ;

OUT       ; -- Kill extra values, Reset ID's/DD from Outpt dialog

 +1        NEW ORD1,ORDLI,ORDFIN,ORDCNT,ORDORIG,ORDORIGF,INSTR,I,ORDD,ORDE

 +2        SET ORDD=$GET(ORDIALOG($$PTR("DISPENSE DRUG"),1))

 +3        SET INSTR=$$PTR("INSTRUCTIONS")

           SET I=0

           FOR 

               SET I=$ORDER(ORDIALOG(INSTR,I))

               if 'I

                   QUIT 

               SET ORDE(I)=$DATA(ORDIALOG($$PTR("DOSE"),I))

 +4        DO DOSES("I")

 +5       ;quit if a complex order

 +6        IF $DATA(ORDIALOG($$PTR^ORCMED("AND/THEN"),1))

               QUIT 

 +7        SET I=0

           FOR 

               SET I=$ORDER(ORDIALOG(INSTR,I))

               if 'I

                   QUIT 

               Begin DoDot:1

 +8                IF ORDE(I)=1

                       IF ($DATA(ORDIALOG($$PTR("DOSE"),I))'=1)

                           Begin DoDot:2

 +9       ;corresponding dosage deleted, wipe the instructions

 +10                           SET ORDIALOG(INSTR,I)=""

                           End DoDot:2

                           QUIT 

 +11               SET ORD1=$PIECE($GET(ORDIALOG($$PTR("DOSE"),I)),"&",5)

 +12               SET ORDORIG=ORDIALOG(INSTR,I)

 +13      ;old sig in comments

                   NEW P

                   IF '$ORDER(ORDIALOG(INSTR,0))

                       Begin DoDot:2

 +14                       NEW WP

                           SET WP=$$PTR("WORD PROCESSING 1")

                           KILL ^TMP("ORSIG",$JOB)

 +15                       MERGE ^TMP("ORSIG",$JOB)=^TMP("ORWORD",$JOB,WP,1)

 +16                       KILL ORDIALOG(WP,1),^TMP("ORWORD",$JOB,WP,1)

                       End DoDot:2

 +17               FOR P="PATIENT INSTRUCTIONS","START DATE/TIME","DAYS SUPPLY","QUANTITY","REFILLS","ROUTING","SERVICE CONNECTED"

                       KILL ORDIALOG($$PTR(P),I)

 +18               IF $GET(ORDIALOG($$PTR("URGENCY"),I))=99

                       KILL ORDIALOG($$PTR("URGENCY"),I)

 +19               SET ORDFIN=""

                   SET ORDCNT=0

                   SET ORDORIGF=0

 +20      ;look in the new instructions list for the original instructions and the possible dose

 +21               IF $LENGTH(ORD1)

                       Begin DoDot:2

 +22                       SET ORDLI=0

                           FOR 

                               SET ORDLI=$ORDER(ORDIALOG(INSTR,"LIST",ORDLI))

                               if 'ORDLI

                                   QUIT 

                               Begin DoDot:3

 +23                               IF $PIECE(ORDIALOG(INSTR,"LIST",ORDLI),U)=ORDORIG

                                       SET ORDORIGF=1

                               End DoDot:3

                       End DoDot:2

 +24      ;look in the returned doses for the local possible dose

 +25               IF '$LENGTH(ORD1)

                       Begin DoDot:2

 +26                       SET ORDOSE=0

                           FOR 

                               SET ORDOSE=$ORDER(ORDOSE(ORDOSE))

                               if 'ORDOSE

                                   QUIT 

                               Begin DoDot:3

 +27                               IF $PIECE(ORDOSE(ORDOSE),U,5)=ORDORIG

                                       IF ($PIECE(ORDOSE(ORDOSE),U,6)=ORDD)

                                           SET ORDFIN=$PIECE(ORDIALOG(INSTR,"LIST",ORDOSE),U)

                                           SET ORDCNT=ORDCNT+1

                               End DoDot:3

                       End DoDot:2

 +28      ;If there was a dose string and original instructions are not in the new instructions list then replace the instructions

 +29               IF ORDE(I)=1

                       IF (ORDORIGF=0)

                           Begin DoDot:2

 +30      ;only one item in the list found containing the dose string - set the instructions to the item found

                               IF ORDCNT=1

                                   SET ORDIALOG(INSTR,I)=ORDFIN

 +31      ;no items or more than one item in the list found containing the dose string - blank the instructions

                               IF ORDCNT'=1

                                   SET ORDIALOG(INSTR,I)=""

                           End DoDot:2

               End DoDot:1

 +32       QUIT 

 +33      ;

DOSES(TYPE) ; -- Convert doses to new TYPE, reset ID strings

 +1        NEW PSOI,ORMED,PROMPT,DOSE,DRUG,I,X,DD,DRUG0,STR

 +2        FOR I="DISPENSE DRUG","STRENGTH","DRUG NAME","SIG"

               KILL ORDIALOG($$PTR(I),1)

 +3        SET PSOI=+$PIECE($GET(^ORD(101.43,+$GET(ORDIALOG($$PTR("ORDERABLE ITEM"),1)),0)),U,2)

           SET ORMED=$PIECE($GET(^(0)),U)

 +4        DO DOSE^PSSORUTL(.ORDOSE,PSOI,TYPE,+ORVP)

           IF $GET(ORDOSE(1))=-1

               KILL ORDOSE

 +5        SET PROMPT=$$PTR("INSTRUCTIONS")

           SET DOSE=$$PTR("DOSE")

 +6        SET DRUG=$$PTR("DISPENSE DRUG")

           DO D1^ORCDPS2

 +7        SET I=0

           FOR 

               SET I=$ORDER(ORDIALOG(PROMPT,I))

               if I'>0

                   QUIT 

               Begin DoDot:1

 +8                KILL ORDIALOG(DOSE,I)

                   SET X=$GET(ORDIALOG(PROMPT,I))

                   if '$LENGTH(X)

                       QUIT 

 +9                SET X=$$UP^XLFSTR(X)

                   SET DD=+$GET(ORDIALOG(PROMPT,"LIST","D",X))

                   if 'DD

                       QUIT 

 +10               SET ORDIALOG(DOSE,I)=$TRANSLATE($GET(ORDOSE("DD",DD,X)),"^","&")

 +11               SET ORDIALOG(DRUG,I)=DD

                   SET DRUG0=$GET(ORDOSE("DD",DD))

 +12               SET STR=$PIECE(DRUG0,U,5)_$PIECE(DRUG0,U,6)

 +13               IF STR'>0

                       if '$GET(ORDOSE(1))

                           SET ORDIALOG($$PTR("DRUG NAME"),1)=$PIECE(DRUG0,U)

                       QUIT 

 +14               IF ORMED'[STR

                       IF TYPE="O"!'$GET(ORDOSE(1))

                           SET ORDIALOG($$PTR("STRENGTH"),1)=STR

               End DoDot:1

 +15       QUIT 

 +16      ;

CONT()    ; -- Want to continue processing orders?

 +1        NEW X,Y,DIR

 +2        SET DIR(0)="YA"

           SET DIR("A")="Do you want to continue transferring orders? "

           SET DIR("B")="YES"

 +3        SET DIR("?")="Enter YES to continue transferring the remaining orders selected, or NO to quit this option."

 +4        DO ^DIR

 +5        QUIT +Y

 +6       ;

SHOWSIG   ; -- Show old sig for transfer in ^TMP("ORSIG",$J)

 +1        NEW ORTX,I,X,ORMAX

           SET ORMAX=72

 +2        SET I=0

           FOR 

               SET I=$ORDER(^TMP("ORSIG",$JOB,I))

               if I'>0

                   QUIT 

               SET X=$GET(^(I,0))

               if $LENGTH(X)

                   DO TXT^ORCHTAB

 +3        SET I=0

           FOR 

               SET I=$ORDER(ORTX(I))

               if I'>0

                   QUIT 

               WRITE !,$SELECT(I=1:"(Sig: ",1:"      ")_ORTX(I)

 +4        WRITE ")"

 +5        QUIT 

 +6       ;

PTR(NAME) ; -- Returns pointer to OR GTX NAME

 +1        QUIT +$ORDER(^ORD(101.41,"AB",$EXTRACT("OR GTX "_NAME,1,63),0))

 +2       ;

REFILLS   ; -- Request a refill for med orders

 +1       ;    ORNMBR = #,#,...,# of selected orders

 +2       ;

 +3        NEW ORLK,ORI,NMBR,IDX,ORIFN,ORDITM,ORERR,ORQUIT,OROUT

 +4        IF '$GET(ORNMBR)

               SET ORNMBR=$$ORDERS^ORCHART("")

               if 'ORNMBR

                   GOTO RFQ

 +5        DO FREEZE^ORCMENU

           SET VALMBCK="R"

 +6        SET ORNP=$$PROVIDER^ORCMENU1

           if ORNP="^"

               GOTO RFQ

 +7        if '$GET(ORL)

               SET ORL=$$LOCATION^ORCMENU1

           if ORL="^"

               GOTO RFQ

 +8        SET OROUT=$$ROUTING

           if OROUT="^"

               GOTO RFQ

 +9        FOR ORI=1:1:$LENGTH(ORNMBR,",")

               SET NMBR=$PIECE(ORNMBR,",",ORI)

               if NMBR

                   Begin DoDot:1

 +10                   SET IDX=$GET(^TMP("OR",$JOB,"CURRENT","IDX",NMBR))

                       SET ORIFN=+$PIECE(IDX,U,4)

 +11                   if 'ORIFN

                           QUIT 

                       IF '$DATA(^OR(100,ORIFN,0))

                           WRITE !,"Invalid order number!"

                           HANG 2

                           QUIT 

 +12                   SET ORDITM=$$ORDITEM^ORCACT(ORIFN)

                       DO SUBHDR^ORCACT(ORDITM)

 +13                   IF '$$VALID^ORCACT0(ORIFN,"RF",.ORERR)

                           WRITE !,ORERR

                           HANG 2

                           QUIT 

 +14                   SET ORLK=$$LOCK1^ORX2(+ORIFN)

                       IF 'ORLK

                           WRITE !,$PIECE(ORLK,U,2)

                           HANG 2

                           QUIT 

 +15                   DO REF^ORMBLDPS(ORIFN,OROUT)

                       DO UNLK1^ORX2(+ORIFN)