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"
+31 SET MSCAX=$$ACTION(MSCCODE,MSCIEN,$GET(DUZ),"",$$NOW^XLFDT,$GET(DUZ))
+32 IF 'MSCAX
QUIT
+33 SET MSCIENS=MSCAX_","_MSCIEN_","
+34 SET MSCFDA(100.008,MSCIENS,15)="@"
+35 SET MSCFDA(100.008,MSCIENS,17)="`"_DUZ
+36 DO UPDATE^DIE("E","MSCFDA","","")
End DoDot:1
+37 KILL ORDEA
ENQ QUIT
+1 ;
NEXTIFN() ; -- Returns next available ORIFN
+1 NEW I,HDR,LAST,TOTAL,DA
+2 FOR I=1:1:10
LOCK +^OR(100,0):1
IF $TEST
QUIT
HANG 2
+3 IF '$TEST
QUIT "^"
+4 SET HDR=$GET(^OR(100,0))
SET TOTAL=+$PIECE(HDR,U,4)
SET LAST=$ORDER(^OR(100,"?"),-1)
+5 SET I=LAST\1
FOR I=(I+1):1
IF '$DATA(^OR(100,I,0))
QUIT
+6 SET DA=I
SET ^OR(100,DA,0)=DA
SET $PIECE(HDR,U,3,4)=DA_U_(TOTAL+1)
+7 SET ^OR(100,0)=HDR
LOCK -^OR(100,0)
+8 QUIT DA
+9 ;
RESPONSE ; -- Save responses in ORDIALOG() into ^OR(100,ORIFN,4.5)
+1 NEW PROMPT,CNT,ITM,TYPE,INST,VALUE,I,START,PAT,X
+2 SET PAT=$PIECE(^OR(100,ORIFN,0),U,2)
SET START=$PIECE(^(0),U,8)
KILL ^(4.5)
+3 SET (PROMPT,CNT)=0
FOR
SET PROMPT=$ORDER(ORDIALOG(PROMPT))
IF PROMPT'>0
QUIT
Begin DoDot:1
+4 SET ITM=$GET(ORDIALOG(PROMPT))
IF 'ITM
QUIT
+5 SET TYPE=$EXTRACT($GET(ORDIALOG(PROMPT,0)))
IF '$LENGTH(TYPE)
QUIT
+6 SET INST=0
FOR
SET INST=$ORDER(ORDIALOG(PROMPT,INST))
IF INST'>0
QUIT
Begin DoDot:2
+7 SET VALUE=$GET(ORDIALOG(PROMPT,INST))
IF VALUE=""
QUIT
SET CNT=CNT+1
+8 SET ^OR(100,ORIFN,4.5,CNT,0)=+ITM_U_PROMPT_U_INST_U_$PIECE(ITM,U,2)
+9 IF $LENGTH($PIECE(ITM,U,2))
SET ^OR(100,ORIFN,4.5,"ID",$PIECE(ITM,U,2),CNT)=""
+10 IF VALUE<1
IF TYPE="N"
SET VALUE=0_+VALUE
IF VALUE="00"
SET VALUE=0
+11 IF TYPE'="W"
SET ^OR(100,ORIFN,4.5,CNT,1)=VALUE
+12 ; array root
IF TYPE="W"
MERGE ^OR(100,ORIFN,4.5,CNT,2)=@VALUE
End DoDot:2
End DoDot:1
+13 SET ^OR(100,ORIFN,4.5,0)="^100.045A^"_CNT_U_CNT
R1 ; [Reset] Orderables
+1 ; kill xref
IF $DATA(^OR(100,ORIFN,.1))
SET I=0
FOR
SET I=$ORDER(^OR(100,ORIFN,.1,I))
IF I'>0
QUIT
SET X=$GET(^(I,0))
IF X
IF PAT
IF START
KILL ^OR(100,"AOI",X,PAT,9999999-START,ORIFN)
+2 KILL ^OR(100,ORIFN,.1)
IF $DATA(^OR(100,ORIFN,4.5,"ID","ORDERABLE"))
Begin DoDot:1
+3 SET (I,CNT)=0
+4 FOR
SET I=$ORDER(^OR(100,ORIFN,4.5,"ID","ORDERABLE",I))
IF I'>0
QUIT
Begin DoDot:2
+5 SET X=$GET(^OR(100,ORIFN,4.5,I,1))
IF 'X
QUIT
+6 SET CNT=CNT+1
SET ^OR(100,ORIFN,.1,CNT,0)=X
SET ^OR(100,ORIFN,.1,"B",X,CNT)=""
+7 IF PAT
IF START
SET ^OR(100,"AOI",X,PAT,9999999-START,ORIFN)=""
End DoDot:2
+8 SET ^OR(100,ORIFN,.1,0)="^100.001PA^"_CNT_U_CNT
End DoDot:1
+9 QUIT
+10 ;
RESUME(IFN) ; -- add Response nodes for RESUME tray service
+1 ; S ^OR(100,+IFN,4.5,<next>,0)=DT_"^^^RESUME",^(1)=1
+2 ;
+3 NEW X,Y,DA,DIC
+4 SET DIC="^OR(100,"_+IFN_",4.5,"
SET DIC(0)="LX"
SET DA(1)=+IFN
SET X=DT
+5 SET DIC("DR")=".04///RESUME"
SET DIC("P")=$PIECE(^DD(100,4.5,0),U,2)
+6 DO ^DIC
IF Y
SET ^OR(100,+IFN,4.5,+Y,1)=1
+7 QUIT
+8 ;
PROVIDER(ORDER,PROV) ; -- Change PROVider assigned to ORDER
+1 IF '$GET(ORDER)
QUIT
IF '$GET(PROV)
QUIT
+2 NEW ORACT
SET ORACT=+$PIECE(ORDER,";",2)
IF 'ORACT
SET ORACT=1
+3 SET $PIECE(^OR(100,+ORDER,8,ORACT,0),U,3)=PROV
+4 IF ORACT=1
SET $PIECE(^OR(100,+ORDER,0),U,4)=PROV
+5 QUIT
+6 ;
ACTION(CODE,DA,PROV,REASON,WHEN,WHO) ; -- save new action
+1 NEW NEXT,TOTAL,HDR,LAST,X,PAT,DGRP,SIG,NATR,TXT
SET DA=+DA
+2 IF '$DATA(^OR(100,DA,0))
QUIT 0
IF $GET(CODE)'?2U
QUIT 0
+3 IF '$GET(WHEN)
SET WHEN=+$EXTRACT($$NOW^XLFDT,1,12)
IF '$GET(WHO)
SET WHO=DUZ
+4 ;assume Elec Entered until changed
SET NATR=+$ORDER(^ORD(100.02,"C","E",0))
+5 SET PAT=$PIECE(^OR(100,DA,0),U,2)
SET DGRP=$PIECE(^(0),U,11)
SET SIG=$PIECE(^(0),U,16)
SET X=+$PIECE($GET(^(3)),U,7)
SET HDR=$GET(^(8,0))
+6 ;current actn's txt ptr
IF X'>0
SET X=1
SET TXT=$PIECE($GET(^OR(100,DA,8,X,0)),U,14)
+7 IF HDR=""
SET HDR="^100.008DA^^"
SET TOTAL=+$PIECE(HDR,U,4)
+8 SET LAST=$ORDER(^OR(100,DA,8,"C",CODE,"?"),-1)
IF LAST
Begin DoDot:1
+9 SET X=$GET(^OR(100,DA,8,LAST,0))
IF $PIECE(X,U,15)'=11
QUIT
IF $PIECE(X,U,4)'=2
QUIT
+10 ; kill old xref entries
SET NEXT=LAST
IF PAT
IF $PIECE(X,U)
Begin DoDot:2
+11 IF DGRP
KILL ^OR(100,"ACT",PAT,(9999999-$PIECE(X,U)),DGRP,DA,NEXT)
+12 KILL ^OR(100,"AC",PAT,(9999999-$PIECE(X,U)),DA,NEXT),^OR(100,"AS",PAT,(9999999-$PIECE(X,U)),DA,NEXT),^OR(100,"AF",$PIECE(X,U),DA,NEXT)
End DoDot:2
End DoDot:1
+13 IF '$GET(NEXT)
SET NEXT=$ORDER(^OR(100,DA,8,"?"),-1)+1
SET TOTAL=TOTAL+1
+14 SET ^OR(100,DA,8,NEXT,0)=WHEN_U_CODE_U_$GET(PROV)_U_$SELECT(SIG:2,1:3)_"^^^^^^^^"_NATR_U_WHO_U_TXT_"^11"
SET ^OR(100,DA,8,"C",CODE,NEXT)=""
+15 SET ^OR(100,"AF",WHEN,DA,NEXT)=""
+16 IF PAT
IF DGRP
SET ^OR(100,"ACT",PAT,9999999-WHEN,DGRP,DA,NEXT)=""
+17 IF PAT
SET ^OR(100,"AC",PAT,9999999-WHEN,DA,NEXT)=""
+18 IF SIG
SET ^OR(100,"AS",PAT,9999999-WHEN,DA,NEXT)=""
+19 IF $LENGTH($GET(REASON))
SET ^OR(100,DA,8,NEXT,1)=REASON
+20 SET $PIECE(HDR,U,3,4)=NEXT_U_TOTAL
SET ^OR(100,DA,8,0)=HDR
+21 QUIT NEXT
+22 ;
SET(DLG) ; -- Create new parent for order set ORDIALOG
+1 ; Returns ORPIFN = ifn of new parent order for set
+2 ;
+3 IF '$GET(ORVP)
QUIT
IF '$GET(DLG)
QUIT
NEW OR0,PKG,NOW,CATG,STS,ORLOC,TRSPEC,X
+4 SET OR0=$GET(^ORD(101.41,DLG,0))
IF OR0=""
QUIT
SET ORPIFN=$$NEXTIFN
IF 'ORPIFN
QUIT
+5 SET PKG=$ORDER(^DIC(9.4,"C","OR",0))
SET CATG=$SELECT($$INPT^ORCD:"I",1:"O")
SET STS=$SELECT($GET(OREVENT):10,1:11)
SET NOW=$SELECT($GET(ORSLOG):ORSLOG,1:+$EXTRACT($$NOW^XLFDT,1,12))
+6 IF $GET(OREVENT)
SET ORLOC=""
SET TRSPEC=""
+7 SET ^OR(100,ORPIFN,0)=ORPIFN_U_ORVP_U_U_$GET(ORNP)_U_DLG_";ORD(101.41,^"_DUZ_U_NOW_U_U_U_ORLOC_U_U_CATG_U_TRSPEC_U_PKG_"^^^"_$GET(OREVENT)
SET ^(3)=NOW_"^90^"_STS_U_$SELECT($GET(ORIT):ORIT_"ORD(101.41,",1:"")_"^^^1^^^^0^^"_+$PIECE(OR0,U,6)
+8 SET ^OR(100,ORPIFN,8,0)="^100.008DA^1^1"
SET ^(1,0)=NOW_"^NW^"_$GET(ORNP)_"^^^^^^^^^^"_DUZ_"^^"_STS
SET ^OR(100,ORPIFN,8,"C","NW",1)=""
SET ^OR(100,"AF",NOW,ORPIFN,1)=""
+9 SET ^OR(100,"ACT",ORVP,9999999-NOW,ORPIFN,1)=""
+10 IF STS=11
SET ^OR(100,"AC",ORVP,9999999-NOW,ORPIFN,1)=""
+11 ; AEVNT ??
+12 ; Order text
SET ^OR(100,ORPIFN,1,0)="^100.011^1^1"
SET ^(1,0)=$PIECE(OR0,U,2)
+13 QUIT
