ORCSAVE.m

ORCSAVE ;SLC/MKB/JDL-Save ;18-Jul-2013 14:23;PLS

 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,56,70,73,92,94,116,141,163,187,190,1006,195,243,303,1010,1011**;Dec 17, 1997;Build 3

 ;Per VHA Directive 2004-038, this routine should not be modified.

 ;Modified - IHS/MSC/PLS - 08/06/10 - Line EN2+21

 ;                       - 07/18/13 - Line EN+14

NEW(ORDIALOG,ORDG,ORPKG,ORCAT,OREVENT,ORDUZ,ORLOG) ; -- New order

 ; Returns ORIFN = [new] order number, if created/saved

 D EN

 Q

 ;

XX ; -- save new/unreleased edited order into Orders file

 ;    Requires: ORDIALOG() = array of dialog values

 ;              ORIFN      = IFN of original order that was edited

 ;

 N OLDIFN S ORIFN=+ORIFN,OLDIFN=0

 I $S($P(^OR(100,ORIFN,3),U,3)=11:0,$P(^(3),U,3)'=10:1,$P(^(8,1,0),U,4)=2:0,1:1) S OLDIFN=ORIFN K ORIFN ; create new order if released or delayed&signed

 D EN Q:'ORIFN  S:'$G(ORDA) ORDA=1

 I $G(OLDIFN) D  ;save links between orders

 . S $P(^OR(100,ORIFN,3),U,5)=OLDIFN,$P(^(3),U,11)=1

 . S $P(^OR(100,OLDIFN,3),U,6)=ORIFN S:$D(^(5)) ^OR(100,ORIFN,5)=^OR(100,OLDIFN,5)

 I $D(^OR(100,+OLDIFN,0)) D

 . Q:'$G(OREVTDF)

 . N OLDEVT,OLDSTS,LSTACT,PATID,NOW,WHEN

 . S (OLDEVT,OLDSTS,LSTACT)=0

 . S NOW=$$NOW^XLFDT

 . S OLDEVT=$P(^(0),U,17),OLDSTS=$P(^(3),U,3)

 . ; Active status = 6 from #100.01

 . I (OLDEVT>0),OLDSTS=6 D

 . . S $P(^OR(100,+ORIFN,0),U,17)=OLDEVT

 . . S $P(^OR(100,+ORIFN,3),U,3)=11

 . . S LSTACT=$P($G(^OR(100,+ORIFN,3)),U,7)

 . . I $D(^OR(100,+ORIFN,8,LSTACT,0)) D

 . . . S $P(^OR(100,+ORIFN,8,LSTACT,0),U,15)=11

 . . . S PATID=$P(^OR(100,+ORIFN,0),U,2)

 . . . S WHEN=$P(^OR(100,+ORIFN,8,LSTACT,0),U)

 . . . S ^OR(100,"AC",PATID,9999999-WHEN,+ORIFN,LSTACT)=""

 Q

 ;

RN ; -- save new/unreleased renewal order into Orders file

 ;    Requires: ORDIALOG() = array of new dialog values

 ;              ORIFN      = IFN of original order that was renewed

 ;

 N OLDIFN S OLDIFN=+ORIFN K ORIFN

 D EN Q:'ORIFN  S:'$G(ORDA) ORDA=1

 S $P(^OR(100,ORIFN,3),U,5)=OLDIFN,$P(^(3),U,11)=2

 S $P(^OR(100,OLDIFN,3),U,6)=ORIFN S:$D(^(5)) ^OR(100,ORIFN,5)=^OR(100,OLDIFN,5)

 Q

 ;

EN ; -- save new/unreleased order in ORDIALOG() into Orders file

 ;    Requires: ORVP, ORNP [and ORL, ORTS, ORAPPT if available]

 ;    If defined: ORCAT,ORPKG,ORDG,ORLOG,ORDUZ,OREVENT,ORDCNTRL,ORSRC

 ;     (else use values from ORDIALOG and current state)

 ;

 N PKG,NOW,NODE,CNT,CDL,I,X,STS,SIGNREQD,LOC,TRSPEC,NATR,CATG,DG,LOG,USR,TYPE

 Q:'$G(ORVP)  Q:'$G(ORDIALOG)  Q:'$D(^ORD(101.41,+ORDIALOG,0))

 S NOW=$$NOW^XLFDT,SIGNREQD=+$P(^ORD(101.41,+ORDIALOG,0),U,6)

 S CATG=$S($L($G(ORCAT)):ORCAT,1:$S($$INPT^ORCD:"I",1:"O"))

 S PKG=$S($G(ORPKG):ORPKG,1:$P(^ORD(101.41,+ORDIALOG,0),U,7))

 I $G(ORIFN),$D(^OR(100,ORIFN,0)) S STS=$P(^(3),U,3) G EN2 ; unrel order

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

 I $G(OREVENT),$$GET1^DIQ(9.4,+PKG_",",1)'="PSO",'$G(DGPMT) S LOC="",TRSPEC="" ;195

 E  S LOC=$G(ORL),TRSPEC=$G(ORTS)

 S:LOC=0 LOC=""  ;IHS/MSC/PLS - 07/18/13

 S TYPE=$S("^B^C^X^P^0^"[(U_$G(ORSRC)_U):ORSRC,$G(ORDCNTRL)="SN":"P",1:0)

 S LOG=$S($G(ORLOG):ORLOG,1:+$E(NOW,1,12)),USR=$S($G(ORDUZ):ORDUZ,1:DUZ)

 S NATR=+$O(^ORD(100.02,"C","E",0)) ;assume Elec Entered until changed

 S STS=$S($G(OREVENT):10,1:11),ORIFN=$$NEXTIFN Q:'ORIFN

EN1 S ^OR(100,ORIFN,0)=ORIFN_U_ORVP_U_U_$G(ORNP)_U_+ORDIALOG_";ORD(101.41,^"_USR_U_LOG_U_U_U_LOC_U_DG_U_CATG_U_TRSPEC_U_PKG_U_U_SIGNREQD_U_$G(OREVENT)_U_$G(ORAPPT)

 S ^OR(100,ORIFN,3)=LOG_"^90^"_STS_U_$S($G(ORIT):ORIT_";ORD(101.41,",1:"")_U_$G(ORDIALOG("PREV"))_"^^1^^^^"_TYPE

 S ^OR(100,ORIFN,8,0)="^100.008DA^1^1",^OR(100,ORIFN,8,1,0)=LOG_"^NW^"_$G(ORNP)_U_$S(SIGNREQD:2,1:3)_"^^^^^^^^"_NATR_U_USR_"^1^"_STS,^OR(100,ORIFN,8,"C","NW",1)=""

 S ^OR(100,"AF",LOG,ORIFN,1)=""

 S ^OR(100,"ACT",ORVP,9999999-LOG,+DG,ORIFN,1)=""

 S:STS'=10 ^OR(100,"AC",ORVP,9999999-LOG,ORIFN,1)=""

 S:SIGNREQD ^OR(100,"AS",ORVP,9999999-LOG,ORIFN,1)=""

 S:$G(OREVENT) ^OR(100,"AEVNT",ORVP,OREVENT,ORIFN)=""

 ;check if OR GTX STUDY REASON is in ORDIALOG and strip out control characters

 N ORRFSID

 S ORRFSID=$O(^ORD(101.41,"B","OR GTX STUDY REASON",""))

 I ORRFSID,$D(ORDIALOG(ORRFSID,1)) D

 .N X,I

 .S X=ORDIALOG(ORRFSID,1)

 .F I=1:1:31 S X=$TR(X,$C(I))

 .S ORDIALOG(ORRFSID,1)=X

EN2 S ORIFN=+ORIFN D RESPONSE ; save responses

 I $P(^OR(100,ORIFN,0),"^",5) D  ;Copy orders PKI fix

 . N OI

 . S OI=+$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",0)),OI=+$G(^OR(100,ORIFN,4.5,OI,1)) Q:'OI

 . I PKG'=$O(^DIC(9.4,"B","OUTPATIENT PHARMACY",0)) Q

 . D PKI^ORWDPS1(.ORY,OI,CATG,+ORVP,$$GET^XPAR("ALL^USR.`"_DUZ,"ORWOR PKI USE",1,"Q"))

 . I $E($G(ORY))=2 S ORDEA=ORY

 K ^OR(100,ORIFN,8,1,.1) D ORDTEXT^ORCSAVE1(ORIFN_";1") ; order text

 S NODE=$G(^OR(100,ORIFN,0)) D  S ^OR(100,ORIFN,0)=NODE

 . S $P(NODE,U,4)=$G(ORNP) ; COST?

 . S I=$O(^OR(100,ORIFN,4.5,"ID","LOCATION",0))

 . I I,$P(NODE,U,10) S X=+$G(^OR(100,ORIFN,4.5,+I,1)) S:X $P(NODE,U,10)=X_";SC(" ;reset Loc if prev value

 . S I=$O(^OR(100,ORIFN,4.5,"ID","CLASS",0))

 . I I S X=$G(^OR(100,ORIFN,4.5,+I,1)) S:"^I^O^"[(U_X_U) $P(NODE,U,12)=X

 S $P(^OR(100,ORIFN,3),U)=NOW

 K ^OR(100,ORIFN,9) I $G(ORCHECK) D  ; save order checks

 . S (CNT,CDL)=0 F  S CDL=$O(ORCHECK("NEW",CDL)) Q:CDL'>0  S I=0 D

 . . F  S I=$O(ORCHECK("NEW",CDL,I)) Q:I'>0  S X=ORCHECK("NEW",CDL,I) D

 . . . S CNT=CNT+1,^OR(100,ORIFN,9,"B",+X,CNT)=""

 . . . S ^OR(100,ORIFN,9,CNT,0)=$P(X,U,1,2),^(1)=$E($P(X,U,3),1,245)

 . S:CNT ^OR(100,ORIFN,9,0)="^100.09PA^"_CNT_U_CNT

 ;IHS/MSC/MGH/PLS - 08/06/10 - Changes to support transfer to IP and OP on home meds

 I $G(TYPE)="X",$G(^TMP("BEHPSHMX",$J)) D  ;,ORIFN)) D

 .N MSCIEN,MSCSTAT,MSCCODE,MSCAX,MSCFDA,MSCIENS

 .S MSCIEN=+^TMP("BEHPSHMX",$J) K ^($J)  ;,ORIFN) K ^($J,ORIFN)

 .S MSCSTAT="TRANSFER TO "_$P($G(^OR(100,ORIFN,0)),U,12)_"P"

 .S MSCSTAT=$O(^ORD(100.01,"B",MSCSTAT,0))

 .Q:'MSCSTAT

 .D STATUS^ORCSAVE2(MSCIEN,MSCSTAT)

 .;IHS/MSC/REC/PLS - 09/21/2010

 .S MSCCODE=$P($G(^OR(100,ORIFN,0)),U,12)_"P"

 .S MSCAX=$$ACTION(MSCCODE,MSCIEN,$G(DUZ),"",$$NOW^XLFDT,$G(DUZ))

 .Q:'MSCAX

 .S MSCIENS=MSCAX_","_MSCIEN_","

 .S MSCFDA(100.008,MSCIENS,15)="@"

 .S MSCFDA(100.008,MSCIENS,17)="`"_DUZ

 .D UPDATE^DIE("E","MSCFDA","","")

 K ORDEA

ENQ Q

 ;

NEXTIFN() ; -- Returns next available ORIFN

 N I,HDR,LAST,TOTAL,DA

 F I=1:1:10 L +^OR(100,0):1 Q:$T  H 2

 I '$T Q "^"

 S HDR=$G(^OR(100,0)),TOTAL=+$P(HDR,U,4),LAST=$O(^OR(100,"?"),-1)

 S I=LAST\1 F I=(I+1):1 Q:'$D(^OR(100,I,0))

 S DA=I,^OR(100,DA,0)=DA,$P(HDR,U,3,4)=DA_U_(TOTAL+1)

 S ^OR(100,0)=HDR L -^OR(100,0)

 Q DA

 ;

RESPONSE ; -- Save responses in ORDIALOG() into ^OR(100,ORIFN,4.5)

 N PROMPT,CNT,ITM,TYPE,INST,VALUE,I,START,PAT,X

 S PAT=$P(^OR(100,ORIFN,0),U,2),START=$P(^(0),U,8) K ^(4.5)

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

 . S ITM=$G(ORDIALOG(PROMPT)) Q:'ITM

 . S TYPE=$E($G(ORDIALOG(PROMPT,0))) Q:'$L(TYPE)

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

 . . S VALUE=$G(ORDIALOG(PROMPT,INST)) Q:VALUE=""  S CNT=CNT+1

 . . S ^OR(100,ORIFN,4.5,CNT,0)=+ITM_U_PROMPT_U_INST_U_$P(ITM,U,2)

 . . S:$L($P(ITM,U,2)) ^OR(100,ORIFN,4.5,"ID",$P(ITM,U,2),CNT)=""

 . . I VALUE<1,TYPE="N" S VALUE=0_+VALUE I VALUE="00" S VALUE=0

 . . S:TYPE'="W" ^OR(100,ORIFN,4.5,CNT,1)=VALUE

 . . M:TYPE="W" ^OR(100,ORIFN,4.5,CNT,2)=@VALUE ; array root

 S ^OR(100,ORIFN,4.5,0)="^100.045A^"_CNT_U_CNT

R1 ; [Reset] Orderables

 I $D(^OR(100,ORIFN,.1)) S I=0 F  S I=$O(^OR(100,ORIFN,.1,I)) Q:I'>0  S X=$G(^(I,0)) I X,PAT,START K ^OR(100,"AOI",X,PAT,9999999-START,ORIFN) ; kill xref

 K ^OR(100,ORIFN,.1) I $D(^OR(100,ORIFN,4.5,"ID","ORDERABLE")) D

 . S (I,CNT)=0

 . F  S I=$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",I)) Q:I'>0  D

 . . S X=$G(^OR(100,ORIFN,4.5,I,1)) Q:'X

 . . S CNT=CNT+1,^OR(100,ORIFN,.1,CNT,0)=X,^OR(100,ORIFN,.1,"B",X,CNT)=""

 . . I PAT,START S ^OR(100,"AOI",X,PAT,9999999-START,ORIFN)=""

 . S ^OR(100,ORIFN,.1,0)="^100.001PA^"_CNT_U_CNT

 Q

 ;

RESUME(IFN) ; -- add Response nodes for RESUME tray service

 ; S ^OR(100,+IFN,4.5,<next>,0)=DT_"^^^RESUME",^(1)=1

 ;

 N X,Y,DA,DIC

 S DIC="^OR(100,"_+IFN_",4.5,",DIC(0)="LX",DA(1)=+IFN,X=DT

 S DIC("DR")=".04///RESUME",DIC("P")=$P(^DD(100,4.5,0),U,2)

 D ^DIC S:Y ^OR(100,+IFN,4.5,+Y,1)=1

 Q

 ;

PROVIDER(ORDER,PROV) ; -- Change PROVider assigned to ORDER

 Q:'$G(ORDER)  Q:'$G(PROV)

 N ORACT S ORACT=+$P(ORDER,";",2) S:'ORACT ORACT=1

 S $P(^OR(100,+ORDER,8,ORACT,0),U,3)=PROV

 S:ORACT=1 $P(^OR(100,+ORDER,0),U,4)=PROV

 Q

 ;

ACTION(CODE,DA,PROV,REASON,WHEN,WHO) ; -- save new action

 N NEXT,TOTAL,HDR,LAST,X,PAT,DGRP,SIG,NATR,TXT S DA=+DA

 Q:'$D(^OR(100,DA,0)) 0 Q:$G(CODE)'?2U 0

 S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) S:'$G(WHO) WHO=DUZ

 S NATR=+$O(^ORD(100.02,"C","E",0)) ;assume Elec Entered until changed

 S PAT=$P(^OR(100,DA,0),U,2),DGRP=$P(^(0),U,11),SIG=$P(^(0),U,16),X=+$P($G(^(3)),U,7),HDR=$G(^(8,0))

 S:X'>0 X=1 S TXT=$P($G(^OR(100,DA,8,X,0)),U,14) ;current actn's txt ptr

 S:HDR="" HDR="^100.008DA^^" S TOTAL=+$P(HDR,U,4)

 S LAST=$O(^OR(100,DA,8,"C",CODE,"?"),-1) I LAST D

 . S X=$G(^OR(100,DA,8,LAST,0)) Q:$P(X,U,15)'=11  Q:$P(X,U,4)'=2

 . S NEXT=LAST I PAT,$P(X,U) D  ; kill old xref entries

 . . K:DGRP ^OR(100,"ACT",PAT,(9999999-$P(X,U)),DGRP,DA,NEXT)

 . . K ^OR(100,"AC",PAT,(9999999-$P(X,U)),DA,NEXT),^OR(100,"AS",PAT,(9999999-$P(X,U)),DA,NEXT),^OR(100,"AF",$P(X,U),DA,NEXT)

 S:'$G(NEXT) NEXT=$O(^OR(100,DA,8,"?"),-1)+1,TOTAL=TOTAL+1

 S ^OR(100,DA,8,NEXT,0)=WHEN_U_CODE_U_$G(PROV)_U_$S(SIG:2,1:3)_"^^^^^^^^"_NATR_U_WHO_U_TXT_"^11",^OR(100,DA,8,"C",CODE,NEXT)=""

 S ^OR(100,"AF",WHEN,DA,NEXT)=""

 I PAT,DGRP S ^OR(100,"ACT",PAT,9999999-WHEN,DGRP,DA,NEXT)=""

 I PAT S ^OR(100,"AC",PAT,9999999-WHEN,DA,NEXT)=""

 I SIG S ^OR(100,"AS",PAT,9999999-WHEN,DA,NEXT)=""

 S:$L($G(REASON)) ^OR(100,DA,8,NEXT,1)=REASON

 S $P(HDR,U,3,4)=NEXT_U_TOTAL,^OR(100,DA,8,0)=HDR

 Q NEXT

 ;

SET(DLG) ; -- Create new parent for order set ORDIALOG

 ; Returns ORPIFN = ifn of new parent order for set

 ;

 Q:'$G(ORVP)  Q:'$G(DLG)  N OR0,PKG,NOW,CATG,STS,ORLOC,TRSPEC,X

 S OR0=$G(^ORD(101.41,DLG,0)) Q:OR0=""  S ORPIFN=$$NEXTIFN Q:'ORPIFN

 S PKG=$O(^DIC(9.4,"C","OR",0)),CATG=$S($$INPT^ORCD:"I",1:"O"),STS=$S($G(OREVENT):10,1:11),NOW=$S($G(ORSLOG):ORSLOG,1:+$E($$NOW^XLFDT,1,12))

 I $G(OREVENT) S ORLOC="",TRSPEC=""

 S ^OR(100,ORPIFN,0)=ORPIFN_U_ORVP_U_U_$G(ORNP)_U_DLG_";ORD(101.41,^"_DUZ_U_NOW_U_U_U_ORLOC_U_U_CATG_U_TRSPEC_U_PKG_"^^^"_$G(OREVENT),^(3)=NOW_"^90^"_STS_U_$S($G(ORIT):ORIT_"ORD(101.41,",1:"")_"^^^1^^^^0^^"_+$P(OR0,U,6)

 S ^OR(100,ORPIFN,8,0)="^100.008DA^1^1",^(1,0)=NOW_"^NW^"_$G(ORNP)_"^^^^^^^^^^"_DUZ_"^^"_STS,^OR(100,ORPIFN,8,"C","NW",1)="",^OR(100,"AF",NOW,ORPIFN,1)=""

 S ^OR(100,"ACT",ORVP,9999999-NOW,ORPIFN,1)=""

 S:STS=11 ^OR(100,"AC",ORVP,9999999-NOW,ORPIFN,1)=""

 ; AEVNT ??

 S ^OR(100,ORPIFN,1,0)="^100.011^1^1",^(1,0)=$P(OR0,U,2) ; Order text

 Q

ORCSAVE   ;SLC/MKB/JDL-Save ;18-Jul-2013 14:23;PLS

 +1       ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,56,70,73,92,94,116,141,163,187,190,1006,195,243,303,1010,1011**;Dec 17, 1997;Build 3

 +2       ;Per VHA Directive 2004-038, this routine should not be modified.

 +3       ;Modified - IHS/MSC/PLS - 08/06/10 - Line EN2+21

 +4       ;                       - 07/18/13 - Line EN+14

NEW(ORDIALOG,ORDG,ORPKG,ORCAT,OREVENT,ORDUZ,ORLOG) ; -- New order

 +1       ; Returns ORIFN = [new] order number, if created/saved

 +2        DO EN

 +3        QUIT 

 +4       ;

XX        ; -- save new/unreleased edited order into Orders file

 +1       ;    Requires: ORDIALOG() = array of dialog values

 +2       ;              ORIFN      = IFN of original order that was edited

 +3       ;

 +4        NEW OLDIFN

           SET ORIFN=+ORIFN

           SET OLDIFN=0

 +5       ; create new order if released or delayed&signed

           IF $SELECT($PIECE(^OR(100,ORIFN,3),U,3)=11:0,$PIECE(^(3),U,3)'=10:1,$PIECE(^(8,1,0),U,4)=2:0,1:1)

               SET OLDIFN=ORIFN

               KILL ORIFN

 +6        DO EN

           IF 'ORIFN

               QUIT 

           IF '$GET(ORDA)

               SET ORDA=1

 +7       ;save links between orders

           IF $GET(OLDIFN)

               Begin DoDot:1

 +8                SET $PIECE(^OR(100,ORIFN,3),U,5)=OLDIFN

                   SET $PIECE(^(3),U,11)=1

 +9                SET $PIECE(^OR(100,OLDIFN,3),U,6)=ORIFN

                   IF $DATA(^(5))

                       SET ^OR(100,ORIFN,5)=^OR(100,OLDIFN,5)

               End DoDot:1

 +10       IF $DATA(^OR(100,+OLDIFN,0))

               Begin DoDot:1

 +11               IF '$GET(OREVTDF)

                       QUIT 

 +12               NEW OLDEVT,OLDSTS,LSTACT,PATID,NOW,WHEN

 +13               SET (OLDEVT,OLDSTS,LSTACT)=0

 +14               SET NOW=$$NOW^XLFDT

 +15               SET OLDEVT=$PIECE(^(0),U,17)

                   SET OLDSTS=$PIECE(^(3),U,3)

 +16      ; Active status = 6 from #100.01

 +17               IF (OLDEVT>0)

                       IF OLDSTS=6

                           Begin DoDot:2

 +18                           SET $PIECE(^OR(100,+ORIFN,0),U,17)=OLDEVT

 +19                           SET $PIECE(^OR(100,+ORIFN,3),U,3)=11

 +20                           SET LSTACT=$PIECE($GET(^OR(100,+ORIFN,3)),U,7)

 +21                           IF $DATA(^OR(100,+ORIFN,8,LSTACT,0))

                                   Begin DoDot:3

 +22                                   SET $PIECE(^OR(100,+ORIFN,8,LSTACT,0),U,15)=11

 +23                                   SET PATID=$PIECE(^OR(100,+ORIFN,0),U,2)

 +24                                   SET WHEN=$PIECE(^OR(100,+ORIFN,8,LSTACT,0),U)

 +25                                   SET ^OR(100,"AC",PATID,9999999-WHEN,+ORIFN,LSTACT)=""

                                   End DoDot:3

                           End DoDot:2

               End DoDot:1

 +26       QUIT 

 +27      ;

RN        ; -- save new/unreleased renewal order into Orders file

 +1       ;    Requires: ORDIALOG() = array of new dialog values

 +2       ;              ORIFN      = IFN of original order that was renewed

 +3       ;

 +4        NEW OLDIFN

           SET OLDIFN=+ORIFN

           KILL ORIFN

 +5        DO EN

           IF 'ORIFN

               QUIT 

           IF '$GET(ORDA)

               SET ORDA=1

 +6        SET $PIECE(^OR(100,ORIFN,3),U,5)=OLDIFN

           SET $PIECE(^(3),U,11)=2

 +7        SET $PIECE(^OR(100,OLDIFN,3),U,6)=ORIFN

           IF $DATA(^(5))

               SET ^OR(100,ORIFN,5)=^OR(100,OLDIFN,5)

 +8        QUIT 

 +9       ;

EN        ; -- save new/unreleased order in ORDIALOG() into Orders file

 +1       ;    Requires: ORVP, ORNP [and ORL, ORTS, ORAPPT if available]

 +2       ;    If defined: ORCAT,ORPKG,ORDG,ORLOG,ORDUZ,OREVENT,ORDCNTRL,ORSRC

 +3       ;     (else use values from ORDIALOG and current state)

 +4       ;

 +5        NEW PKG,NOW,NODE,CNT,CDL,I,X,STS,SIGNREQD,LOC,TRSPEC,NATR,CATG,DG,LOG,USR,TYPE

 +6        IF '$GET(ORVP)

               QUIT 

           IF '$GET(ORDIALOG)

               QUIT 

           IF '$DATA(^ORD(101.41,+ORDIALOG,0))

               QUIT 

 +7        SET NOW=$$NOW^XLFDT

           SET SIGNREQD=+$PIECE(^ORD(101.41,+ORDIALOG,0),U,6)

 +8        SET CATG=$SELECT($LENGTH($GET(ORCAT)):ORCAT,1:$SELECT($$INPT^ORCD:"I",1:"O"))

 +9        SET PKG=$SELECT($GET(ORPKG):ORPKG,1:$PIECE(^ORD(101.41,+ORDIALOG,0),U,7))

 +10      ; unrel order

           IF $GET(ORIFN)

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

                   SET STS=$PIECE(^(3),U,3)

                   GOTO EN2

 +11       SET DG=$SELECT($GET(ORDG):+ORDG,1:$PIECE(^ORD(101.41,+ORDIALOG,0),U,5))

 +12      ;195

           IF $GET(OREVENT)

               IF $$GET1^DIQ(9.4,+PKG_",",1)'="PSO"

                   IF '$GET(DGPMT)

                       SET LOC=""

                       SET TRSPEC=""

 +13      IF '$TEST

               SET LOC=$GET(ORL)

               SET TRSPEC=$GET(ORTS)

 +14      ;IHS/MSC/PLS - 07/18/13

           IF LOC=0

               SET LOC=""

 +15       SET TYPE=$SELECT("^B^C^X^P^0^"[(U_$GET(ORSRC)_U):ORSRC,$GET(ORDCNTRL)="SN":"P",1:0)

 +16       SET LOG=$SELECT($GET(ORLOG):ORLOG,1:+$EXTRACT(NOW,1,12))

           SET USR=$SELECT($GET(ORDUZ):ORDUZ,1:DUZ)

 +17      ;assume Elec Entered until changed

           SET NATR=+$ORDER(^ORD(100.02,"C","E",0))

 +18       SET STS=$SELECT($GET(OREVENT):10,1:11)

           SET ORIFN=$$NEXTIFN

           IF 'ORIFN

               QUIT 

EN1        SET ^OR(100,ORIFN,0)=ORIFN_U_ORVP_U_U_$GET(ORNP)_U_+ORDIALOG_";ORD(101.41,^"_USR_U_LOG_U_U_U_LOC_U_DG_U_CATG_U_TRSPEC_U_PKG_U_U_SIGNREQD_U_$GET(OREVENT)_U_$GET(ORAPPT)

 +1        SET ^OR(100,ORIFN,3)=LOG_"^90^"_STS_U_$SELECT($GET(ORIT):ORIT_";ORD(101.41,",1:"")_U_$GET(ORDIALOG("PREV"))_"^^1^^^^"_TYPE

 +2        SET ^OR(100,ORIFN,8,0)="^100.008DA^1^1"

           SET ^OR(100,ORIFN,8,1,0)=LOG_"^NW^"_$GET(ORNP)_U_$SELECT(SIGNREQD:2,1:3)_"^^^^^^^^"_NATR_U_USR_"^1^"_STS

           SET ^OR(100,ORIFN,8,"C","NW",1)=""

 +3        SET ^OR(100,"AF",LOG,ORIFN,1)=""

 +4        SET ^OR(100,"ACT",ORVP,9999999-LOG,+DG,ORIFN,1)=""

 +5        IF STS'=10

               SET ^OR(100,"AC",ORVP,9999999-LOG,ORIFN,1)=""

 +6        IF SIGNREQD

               SET ^OR(100,"AS",ORVP,9999999-LOG,ORIFN,1)=""

 +7        IF $GET(OREVENT)

               SET ^OR(100,"AEVNT",ORVP,OREVENT,ORIFN)=""

 +8       ;check if OR GTX STUDY REASON is in ORDIALOG and strip out control characters

 +9        NEW ORRFSID

 +10       SET ORRFSID=$ORDER(^ORD(101.41,"B","OR GTX STUDY REASON",""))

 +11       IF ORRFSID

               IF $DATA(ORDIALOG(ORRFSID,1))

                   Begin DoDot:1

 +12                   NEW X,I

 +13                   SET X=ORDIALOG(ORRFSID,1)

 +14                   FOR I=1:1:31

                           SET X=$TRANSLATE(X,$CHAR(I))

 +15                   SET ORDIALOG(ORRFSID,1)=X

                   End DoDot:1

EN2       ; save responses

           SET ORIFN=+ORIFN

           DO RESPONSE

 +1       ;Copy orders PKI fix

           IF $PIECE(^OR(100,ORIFN,0),"^",5)

               Begin DoDot:1

 +2                NEW OI

 +3                SET OI=+$ORDER(^OR(100,ORIFN,4.5,"ID","ORDERABLE",0))

                   SET OI=+$GET(^OR(100,ORIFN,4.5,OI,1))

                   IF 'OI

                       QUIT 

 +4                IF PKG'=$ORDER(^DIC(9.4,"B","OUTPATIENT PHARMACY",0))

                       QUIT 

 +5                DO PKI^ORWDPS1(.ORY,OI,CATG,+ORVP,$$GET^XPAR("ALL^USR.`"_DUZ,"ORWOR PKI USE",1,"Q"))

 +6                IF $EXTRACT($GET(ORY))=2

                       SET ORDEA=ORY

               End DoDot:1

 +7       ; order text

           KILL ^OR(100,ORIFN,8,1,.1)

           DO ORDTEXT^ORCSAVE1(ORIFN_";1")

 +8        SET NODE=$GET(^OR(100,ORIFN,0))

           Begin DoDot:1

 +9       ; COST?

               SET $PIECE(NODE,U,4)=$GET(ORNP)

 +10           SET I=$ORDER(^OR(100,ORIFN,4.5,"ID","LOCATION",0))

 +11      ;reset Loc if prev value

               IF I

                   IF $PIECE(NODE,U,10)

                       SET X=+$GET(^OR(100,ORIFN,4.5,+I,1))

                       IF X

                           SET $PIECE(NODE,U,10)=X_";SC("

 +12           SET I=$ORDER(^OR(100,ORIFN,4.5,"ID","CLASS",0))

 +13           IF I

                   SET X=$GET(^OR(100,ORIFN,4.5,+I,1))

                   IF "^I^O^"[(U_X_U)

                       SET $PIECE(NODE,U,12)=X

           End DoDot:1

           SET ^OR(100,ORIFN,0)=NODE

 +14       SET $PIECE(^OR(100,ORIFN,3),U)=NOW

 +15      ; save order checks

           KILL ^OR(100,ORIFN,9)

           IF $GET(ORCHECK)

               Begin DoDot:1

 +16               SET (CNT,CDL)=0

                   FOR 

                       SET CDL=$ORDER(ORCHECK("NEW",CDL))

                       IF CDL'>0

                           QUIT 

                       SET I=0

                       Begin DoDot:2

 +17                       FOR 

                               SET I=$ORDER(ORCHECK("NEW",CDL,I))

                               IF I'>0

                                   QUIT 

                               SET X=ORCHECK("NEW",CDL,I)

                               Begin DoDot:3

 +18                               SET CNT=CNT+1

                                   SET ^OR(100,ORIFN,9,"B",+X,CNT)=""

 +19                               SET ^OR(100,ORIFN,9,CNT,0)=$PIECE(X,U,1,2)

                                   SET ^(1)=$EXTRACT($PIECE(X,U,3),1,245)

                               End DoDot:3

                       End DoDot:2

 +20               IF CNT

                       SET ^OR(100,ORIFN,9,0)="^100.09PA^"_CNT_U_CNT

               End DoDot:1

 +21      ;IHS/MSC/MGH/PLS - 08/06/10 - Changes to support transfer to IP and OP on home meds

 +22      ;,ORIFN)) D

           IF $GET(TYPE)="X"

               IF $GET(^TMP("BEHPSHMX",$JOB))

                   Begin DoDot:1

 +23                   NEW MSCIEN,MSCSTAT,MSCCODE,MSCAX,MSCFDA,MSCIENS

 +24      ;,ORIFN) K ^($J,ORIFN)

                       SET MSCIEN=+^TMP("BEHPSHMX",$JOB)

                       KILL ^($JOB)

 +25                   SET MSCSTAT="TRANSFER TO "_$PIECE($GET(^OR(100,ORIFN,0)),U,12)_"P"

 +26                   SET MSCSTAT=$ORDER(^ORD(100.01,"B",MSCSTAT,0))

 +27                   IF 'MSCSTAT

                           QUIT 

 +28                   DO STATUS^ORCSAVE2(MSCIEN,MSCSTAT)

 +29      ;IHS/MSC/REC/PLS - 09/21/2010

 +30                   SET MSCCODE=$PIECE($GET(^OR(100,ORIFN,0)),U,12)_"P"