- ORCSAVE ;SLC/MKB/JDL-Save ;Dec 02, 2021@13:09:37
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,56,70,73,92,94,116,141,163,187,190,195,243,303,293,280,306,286,269,423,421,382,397,377,453,405,499**;Dec 17, 1997;Build 165
- ;Per VA Directive 6402, this routine should not be modified.
- ;
- ; DBIA 10103 ^XLFDT
- ;
- 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
- ;
- D ORCAN^ORNORC(+ORIFN,"CH") ; ajb *377
- 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(^OR(100,+OLDIFN,0),U,17),OLDSTS=$P(^OR(100,+OLDIFN,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,ORK,ORCSORD
- 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))
- S LOG=$S($G(ORLOG):ORLOG,1:+$E(NOW,1,12)),USR=$S($G(ORDUZ):ORDUZ,1:DUZ)
- 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),"^PSO^RA^"'["^"_$$GET1^DIQ(9.4,+PKG_",",1)_"^",'$G(DGPMT) S LOC="",TRSPEC="" ; p286 added radiology package
- E S LOC=$G(ORL),TRSPEC=$G(ORTS)
- 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) moved up before EN2 call
- 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)=""
- ;Indication for use
- I $G(INDICAT)'="" S $P(^OR(100,ORIFN,10),U,2)=INDICAT
- S ^OR(100,"AF",LOG,ORIFN,1)=""
- ; RBD OR*3.0*453 Add setting of EPRACDT index explicitly
- I $G(ORNP)]"" S ^OR(100,"EPRACDT",ORNP,LOG,ORIFN,1)=""
- S ^OR(100,"C",+ORDIALOG_";ORD(101.41,",ORIFN)="" ;patch 423
- S:+$G(ORIT) ^OR(100,"D",+ORIT_";ORD(101.41,",ORIFN)="" ;patch 423
- I $G(ORSLDEA)]"" S $P(^OR(100,ORIFN,11.1),U)=ORSLDEA ;patch 499
- 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,ORPKIU
- . 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
- . S ORPKIU=0 I $D(^ORD(100.7,"C",DUZ)) S ORPKIU=1
- . D PKI^ORWDPS1(.ORY,OI,CATG,+ORVP,ORPKIU)
- . I $E($G(ORY))=2 S ORDEA=ORY
- ;
- ; Update: Order Text, External Text, Drug Schedule, Digital Sig Required
- I $G(^OR(100,ORIFN,8,1,2))'="" S $P(^OR(100,ORIFN,8,1,2),"^",4,5)="^"
- K ^OR(100,ORIFN,8,1,.2)
- K ^OR(100,ORIFN,8,1,.1)
- D ORDTEXT^ORCSAVE1(ORIFN_";1")
- ;
- S NODE=$G(^OR(100,ORIFN,8,1,0)) D S ^OR(100,ORIFN,8,1,0)=NODE
- . S $P(NODE,U,3)=$G(ORNP)
- . S $P(NODE,U,13)=USR
- S NODE=$G(^OR(100,ORIFN,0)) D S ^OR(100,ORIFN,0)=NODE
- . S $P(NODE,U,4)=$G(ORNP)
- . 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
- ;Audit certain fields for CS ePCS Order so that we have an audit of changes to unsigned CS orders.
- S ORCSORD=""
- D CSVALUE^ORDEA(.ORCSORD,ORIFN)
- I ORCSORD D AUDORDXX^ORDEA(ORIFN)
- ;
- D DELOCC^OROCAPI1(ORIFN,"ACCEPTANCE_CPRS")
- I $G(ORCHECK) D ; save order checks
- . N ORCROC
- . 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 D
- . . . I $D(ORCHECK("NEW",CDL,I,0)) D
- . . . . N J S J=0,ORCHECK("NEW",CDL,I)=ORCHECK("NEW",CDL,I,J) F S J=$O(ORCHECK("NEW",CDL,I,J)) Q:'J S ORCHECK("NEW",CDL,I)=ORCHECK("NEW",CDL,I)_ORCHECK("NEW",CDL,I,J)
- . . . S X=ORCHECK("NEW",CDL,I)
- . . . S ORK(I,1)=+ORIFN_U_"ACCEPTANCE_CPRS"_U_DUZ_U_$$NOW^XLFDT_U_$P(X,U)_U_CDL
- . . . S ORK(I,2,1)=$P(X,U,3)
- . . . I $E(ORK(I,2,1),0,2)="||" D
- . . . . N ORGLOB,ORRULE,ORI,ORLINE
- . . . . S ORGLOB=$P($P(ORK(I,2,1),"||",2),"&"),ORRULE=$P($P(ORK(I,2,1),"||",2),"&",2)
- . . . . S ORCROC(I)=$P($P(ORK(I,2,1),"||",2),"&",3)_U_$P($P(ORK(I,2,1),"||",2),"&",4)
- . . . . S ORK(I,2,1)=ORRULE,ORI=0,ORLINE=2
- . . . . F S ORI=$O(^TMP($J,"ORK XTRA TXT",ORGLOB,ORRULE,ORI)) Q:'ORI S ORK(I,2,ORLINE)=^TMP($J,"ORK XTRA TXT",ORGLOB,ORRULE,ORI),ORLINE=ORLINE+1
- . . . S ORK(I,3)=$G(ORCHECK("NEW",CDL,I,"OVER"))
- . . . S ORK(I,4)=$G(ORCHECK("NEW",CDL,I,"REMCOMM"))
- . I $D(ORK) D
- . . N OCRET,ORKI
- . . D SAVEOC^OROCAPI1(.ORK,.OCRET)
- . . I $D(ORCROC) D
- . . . N ORCROCI S ORCROCI=0 F S ORCROCI=$O(ORCROC(ORCROCI)) Q:'ORCROCI D
- . . . . N OCINST S OCINST=$O(OCRET(ORCROCI,"")) Q:'OCINST D
- . . . . . S ^ORD(100.05,OCINST,12)=ORCROC(ORCROCI)
- . . S ORKI=0 F S ORKI=$O(ORK(ORKI)) Q:'ORKI D
- . . . N OCINST,OCTXT S OCTXT=$G(ORK(ORKI,2,1))
- . . . S OCINST=$O(OCRET(ORKI,0))
- . . . N ORMONOI,ORMONOQ S ORMONOI=0,ORMONOQ=0 F Q:ORMONOQ=1 S ORMONOI=$O(^TMP($J,"ORMONOGRAPH",ORMONOI)) Q:'ORMONOI D
- . . . . I OCTXT[$G(^TMP($J,"ORMONOGRAPH",ORMONOI,"OC")) D
- . . . . . S ORMONOQ=1
- . . . . . S ^ORD(100.05,OCINST,17)=^TMP($J,"ORMONOGRAPH",ORMONOI,"INT")
- . . . . . M ^ORD(100.05,OCINST,16)=^TMP($J,"ORMONOGRAPH",ORMONOI,"DATA")
- . . . . . S ^ORD(100.05,OCINST,16,0)="^^"_$O(^ORD(100.05,OCINST,16,""),-1)_U_$O(^ORD(100.05,OCINST,16,""),-1)_U_+$$NOW^XLFDT_U
- . . K ^TMP($J,"ORMONOGRAPH")
- . . K ^TMP($J,"ORK XTRA TXT")
- K ORDEA
- ENQ Q
- ;
- NEXTIFN() ; -- Returns next available ORIFN
- N I,HDR,LAST,TOTAL,DA
- L +^OR(100,0):$S($G(DILOCKTM)>0:DILOCKTM,1:5)
- 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,DLAYGO,MSG
- D FIELD^DID(100,4.5,"","SPECIFIER","MSG")
- S DIC="^OR(100,"_+IFN_",4.5,",DIC(0)="LX",DA(1)=+IFN,X=DT
- S DIC("DR")=".04///RESUME",DIC("P")=$G(MSG("SPECIFIER")),DLAYGO=100
- 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)
- . . I $P(X,U,3) K ^OR(100,"EPRACDT",$P(X,U,3),$P(X,U),DA,NEXT) ; RBD OR*3.0*453 Handle Kill of EPRACDT index as AF index is done
- 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 $G(PROV)]"",CODE="NW" S ^OR(100,"EPRACDT",PROV,WHEN,DA,NEXT)="" ; RBD OR*3.0*453 Handle Set of EPRACDT index
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCSAVE 13176 printed Jan 18, 2025@03:30:08 Page 2
- ORCSAVE ;SLC/MKB/JDL-Save ;Dec 02, 2021@13:09:37
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,56,70,73,92,94,116,141,163,187,190,195,243,303,293,280,306,286,269,423,421,382,397,377,453,405,499**;Dec 17, 1997;Build 165
- +2 ;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ; DBIA 10103 ^XLFDT
- +5 ;
- 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 ; ajb *377
- DO ORCAN^ORNORC(+ORIFN,"CH")
- +5 NEW OLDIFN
- SET ORIFN=+ORIFN
- SET OLDIFN=0
- +6 ; 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
- +7 DO EN
- if 'ORIFN
- QUIT
- if '$GET(ORDA)
- SET ORDA=1
- +8 ;save links between orders
- IF $GET(OLDIFN)
- Begin DoDot:1
- +9 SET $PIECE(^OR(100,ORIFN,3),U,5)=OLDIFN
- SET $PIECE(^(3),U,11)=1
- +10 SET $PIECE(^OR(100,OLDIFN,3),U,6)=ORIFN
- if $DATA(^(5))
- SET ^OR(100,ORIFN,5)=^OR(100,OLDIFN,5)
- End DoDot:1
- +11 IF $DATA(^OR(100,+OLDIFN,0))
- Begin DoDot:1
- +12 if '$GET(OREVTDF)
- QUIT
- +13 NEW OLDEVT,OLDSTS,LSTACT,PATID,NOW,WHEN
- +14 SET (OLDEVT,OLDSTS,LSTACT)=0
- +15 SET NOW=$$NOW^XLFDT
- +16 SET OLDEVT=$PIECE(^OR(100,+OLDIFN,0),U,17)
- SET OLDSTS=$PIECE(^OR(100,+OLDIFN,3),U,3)
- +17 ; Active status = 6 from #100.01
- +18 IF (OLDEVT>0)
- IF OLDSTS=6
- Begin DoDot:2
- +19 SET $PIECE(^OR(100,+ORIFN,0),U,17)=OLDEVT
- +20 SET $PIECE(^OR(100,+ORIFN,3),U,3)=11
- +21 SET LSTACT=$PIECE($GET(^OR(100,+ORIFN,3)),U,7)
- +22 IF $DATA(^OR(100,+ORIFN,8,LSTACT,0))
- Begin DoDot:3
- +23 SET $PIECE(^OR(100,+ORIFN,8,LSTACT,0),U,15)=11
- +24 SET PATID=$PIECE(^OR(100,+ORIFN,0),U,2)
- +25 SET WHEN=$PIECE(^OR(100,+ORIFN,8,LSTACT,0),U)
- +26 SET ^OR(100,"AC",PATID,9999999-WHEN,+ORIFN,LSTACT)=""
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +27 QUIT
- +28 ;
- 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,ORK,ORCSORD
- +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 SET LOG=$SELECT($GET(ORLOG):ORLOG,1:+$EXTRACT(NOW,1,12))
- SET USR=$SELECT($GET(ORDUZ):ORDUZ,1:DUZ)
- +11 ; unrel order
- IF $GET(ORIFN)
- IF $DATA(^OR(100,ORIFN,0))
- SET STS=$PIECE(^(3),U,3)
- GOTO EN2
- +12 SET DG=$SELECT($GET(ORDG):+ORDG,1:$PIECE(^ORD(101.41,+ORDIALOG,0),U,5))
- +13 ; p286 added radiology package
- IF $GET(OREVENT)
- IF "^PSO^RA^"'["^"_$$GET1^DIQ(9.4,+PKG_",",1)_"^"
- IF '$GET(DGPMT)
- SET LOC=""
- SET TRSPEC=""
- +14 IF '$TEST
- SET LOC=$GET(ORL)
- SET TRSPEC=$GET(ORTS)
- +15 SET TYPE=$SELECT("^B^C^X^P^0^"[(U_$GET(ORSRC)_U):ORSRC,$GET(ORDCNTRL)="SN":"P",1:0)
- +16 ;S LOG=$S($G(ORLOG):ORLOG,1:+$E(NOW,1,12)),USR=$S($G(ORDUZ):ORDUZ,1:DUZ) moved up before EN2 call
- +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 ;Indication for use
- +4 IF $GET(INDICAT)'=""
- SET $PIECE(^OR(100,ORIFN,10),U,2)=INDICAT
- +5 SET ^OR(100,"AF",LOG,ORIFN,1)=""
- +6 ; RBD OR*3.0*453 Add setting of EPRACDT index explicitly
- +7 IF $GET(ORNP)]""
- SET ^OR(100,"EPRACDT",ORNP,LOG,ORIFN,1)=""
- +8 ;patch 423
- SET ^OR(100,"C",+ORDIALOG_";ORD(101.41,",ORIFN)=""
- +9 ;patch 423
- if +$GET(ORIT)
- SET ^OR(100,"D",+ORIT_";ORD(101.41,",ORIFN)=""
- +10 ;patch 499
- IF $GET(ORSLDEA)]""
- SET $PIECE(^OR(100,ORIFN,11.1),U)=ORSLDEA
- +11 SET ^OR(100,"ACT",ORVP,9999999-LOG,+DG,ORIFN,1)=""
- +12 if STS'=10
- SET ^OR(100,"AC",ORVP,9999999-LOG,ORIFN,1)=""
- +13 if SIGNREQD
- SET ^OR(100,"AS",ORVP,9999999-LOG,ORIFN,1)=""
- +14 if $GET(OREVENT)
- SET ^OR(100,"AEVNT",ORVP,OREVENT,ORIFN)=""
- +15 ;check if OR GTX STUDY REASON is in ORDIALOG and strip out control characters
- +16 NEW ORRFSID
- +17 SET ORRFSID=$ORDER(^ORD(101.41,"B","OR GTX STUDY REASON",""))
- +18 IF ORRFSID
- IF $DATA(ORDIALOG(ORRFSID,1))
- Begin DoDot:1
- +19 NEW X,I
- +20 SET X=ORDIALOG(ORRFSID,1)
- +21 FOR I=1:1:31
- SET X=$TRANSLATE(X,$CHAR(I))
- +22 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,ORPKIU
- +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 SET ORPKIU=0
- IF $DATA(^ORD(100.7,"C",DUZ))
- SET ORPKIU=1
- +6 DO PKI^ORWDPS1(.ORY,OI,CATG,+ORVP,ORPKIU)
- +7 IF $EXTRACT($GET(ORY))=2
- SET ORDEA=ORY
- End DoDot:1
- +8 ;
- +9 ; Update: Order Text, External Text, Drug Schedule, Digital Sig Required
- +10 IF $GET(^OR(100,ORIFN,8,1,2))'=""
- SET $PIECE(^OR(100,ORIFN,8,1,2),"^",4,5)="^"
- +11 KILL ^OR(100,ORIFN,8,1,.2)
- +12 KILL ^OR(100,ORIFN,8,1,.1)
- +13 DO ORDTEXT^ORCSAVE1(ORIFN_";1")
- +14 ;
- +15 SET NODE=$GET(^OR(100,ORIFN,8,1,0))
- Begin DoDot:1
- +16 SET $PIECE(NODE,U,3)=$GET(ORNP)
- +17 SET $PIECE(NODE,U,13)=USR
- End DoDot:1
- SET ^OR(100,ORIFN,8,1,0)=NODE
- +18 SET NODE=$GET(^OR(100,ORIFN,0))
- Begin DoDot:1
- +19 SET $PIECE(NODE,U,4)=$GET(ORNP)
- +20 SET I=$ORDER(^OR(100,ORIFN,4.5,"ID","LOCATION",0))
- +21 ;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("
- +22 SET I=$ORDER(^OR(100,ORIFN,4.5,"ID","CLASS",0))
- +23 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
- +24 SET $PIECE(^OR(100,ORIFN,3),U)=NOW
- +25 ;Audit certain fields for CS ePCS Order so that we have an audit of changes to unsigned CS orders.
- +26 SET ORCSORD=""
- +27 DO CSVALUE^ORDEA(.ORCSORD,ORIFN)
- +28 IF ORCSORD
- DO AUDORDXX^ORDEA(ORIFN)
- +29 ;
- +30 DO DELOCC^OROCAPI1(ORIFN,"ACCEPTANCE_CPRS")
- +31 ; save order checks
- IF $GET(ORCHECK)
- Begin DoDot:1
- +32 NEW ORCROC
- +33 SET (CNT,CDL)=0
- FOR
- SET CDL=$ORDER(ORCHECK("NEW",CDL))
- if CDL'>0
- QUIT
- SET I=0
- Begin DoDot:2
- +34 FOR
- SET I=$ORDER(ORCHECK("NEW",CDL,I))
- if I'>0
- QUIT
- Begin DoDot:3
- +35 IF $DATA(ORCHECK("NEW",CDL,I,0))
- Begin DoDot:4
- +36 NEW J
- SET J=0
- SET ORCHECK("NEW",CDL,I)=ORCHECK("NEW",CDL,I,J)
- FOR
- SET J=$ORDER(ORCHECK("NEW",CDL,I,J))
- if 'J
- QUIT
- SET ORCHECK("NEW",CDL,I)=ORCHECK("NEW",CDL,I)_ORCHECK("NEW",CDL,I,J)
- End DoDot:4
- +37 SET X=ORCHECK("NEW",CDL,I)
- +38 SET ORK(I,1)=+ORIFN_U_"ACCEPTANCE_CPRS"_U_DUZ_U_$$NOW^XLFDT_U_$P(X,U)_U_CDL
- +39 SET ORK(I,2,1)=$PIECE(X,U,3)
- +40 IF $EXTRACT(ORK(I,2,1),0,2)="||"
- Begin DoDot:4
- +41 NEW ORGLOB,ORRULE,ORI,ORLINE
- +42 SET ORGLOB=$PIECE($PIECE(ORK(I,2,1),"||",2),"&")
- SET ORRULE=$PIECE($PIECE(ORK(I,2,1),"||",2),"&",2)
- +43 SET ORCROC(I)=$PIECE($PIECE(ORK(I,2,1),"||",2),"&",3)_U_$PIECE($PIECE(ORK(I,2,1),"||",2),"&",4)
- +44 SET ORK(I,2,1)=ORRULE
- SET ORI=0
- SET ORLINE=2
- +45 FOR
- SET ORI=$ORDER(^TMP($JOB,"ORK XTRA TXT",ORGLOB,ORRULE,ORI))
- if 'ORI
- QUIT
- SET ORK(I,2,ORLINE)=^TMP($JOB,"ORK XTRA TXT",ORGLOB,ORRULE,ORI)
- SET ORLINE=ORLINE+1
- End DoDot:4
- +46 SET ORK(I,3)=$GET(ORCHECK("NEW",CDL,I,"OVER"))
- +47 SET ORK(I,4)=$GET(ORCHECK("NEW",CDL,I,"REMCOMM"))
- End DoDot:3
- End DoDot:2
- +48 IF $DATA(ORK)
- Begin DoDot:2
- +49 NEW OCRET,ORKI
- +50 DO SAVEOC^OROCAPI1(.ORK,.OCRET)
- +51 IF $DATA(ORCROC)
- Begin DoDot:3
- +52 NEW ORCROCI
- SET ORCROCI=0
- FOR
- SET ORCROCI=$ORDER(ORCROC(ORCROCI))
- if 'ORCROCI
- QUIT
- Begin DoDot:4
- +53 NEW OCINST
- SET OCINST=$ORDER(OCRET(ORCROCI,""))
- if 'OCINST
- QUIT
- Begin DoDot:5
- +54 SET ^ORD(100.05,OCINST,12)=ORCROC(ORCROCI)
- End DoDot:5
- End DoDot:4
- End DoDot:3
- +55 SET ORKI=0
- FOR
- SET ORKI=$ORDER(ORK(ORKI))
- if 'ORKI
- QUIT
- Begin DoDot:3
- +56 NEW OCINST,OCTXT
- SET OCTXT=$GET(ORK(ORKI,2,1))
- +57 SET OCINST=$ORDER(OCRET(ORKI,0))
- +58 NEW ORMONOI,ORMONOQ
- SET ORMONOI=0
- SET ORMONOQ=0
- FOR
- if ORMONOQ=1
- QUIT
- SET ORMONOI=$ORDER(^TMP($JOB,"ORMONOGRAPH",ORMONOI))
- if 'ORMONOI
- QUIT
- Begin DoDot:4
- +59 IF OCTXT[$GET(^TMP($JOB,"ORMONOGRAPH",ORMONOI,"OC"))
- Begin DoDot:5
- +60 SET ORMONOQ=1
- +61 SET ^ORD(100.05,OCINST,17)=^TMP($JOB,"ORMONOGRAPH",ORMONOI,"INT")
- +62 MERGE ^ORD(100.05,OCINST,16)=^TMP($JOB,"ORMONOGRAPH",ORMONOI,"DATA")
- +63 SET ^ORD(100.05,OCINST,16,0)="^^"_$ORDER(^ORD(100.05,OCINST,16,""),-1)_U_$ORDER(^ORD(100.05,OCINST,16,""),-1)_U_+$$NOW^XLFDT_U
- End DoDot:5
- End DoDot:4
- End DoDot:3
- +64 KILL ^TMP($JOB,"ORMONOGRAPH")
- +65 KILL ^TMP($JOB,"ORK XTRA TXT")
- End DoDot:2
- End DoDot:1
- +66 KILL ORDEA
- ENQ QUIT
- +1 ;
- NEXTIFN() ; -- Returns next available ORIFN
- +1 NEW I,HDR,LAST,TOTAL,DA
- +2 LOCK +^OR(100,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:5)
- +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,DLAYGO,MSG
- +4 DO FIELD^DID(100,4.5,"","SPECIFIER","MSG")
- +5 SET DIC="^OR(100,"_+IFN_",4.5,"
- SET DIC(0)="LX"
- SET DA(1)=+IFN
- SET X=DT
- +6 SET DIC("DR")=".04///RESUME"
- SET DIC("P")=$GET(MSG("SPECIFIER"))
- SET DLAYGO=100
- +7 DO ^DIC
- if Y
- SET ^OR(100,+IFN,4.5,+Y,1)=1
- +8 QUIT
- +9 ;
- 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)
- +13 ; RBD OR*3.0*453 Handle Kill of EPRACDT index as AF index is done
- IF $PIECE(X,U,3)
- KILL ^OR(100,"EPRACDT",$PIECE(X,U,3),$PIECE(X,U),DA,NEXT)
- End DoDot:2
- End DoDot:1
- +14 if '$GET(NEXT)
- SET NEXT=$ORDER(^OR(100,DA,8,"?"),-1)+1
- SET TOTAL=TOTAL+1
- +15 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)=""
- +16 SET ^OR(100,"AF",WHEN,DA,NEXT)=""
- +17 ; RBD OR*3.0*453 Handle Set of EPRACDT index
- IF $GET(PROV)]""
- IF CODE="NW"
- SET ^OR(100,"EPRACDT",PROV,WHEN,DA,NEXT)=""
- +18 IF PAT
- IF DGRP
- SET ^OR(100,"ACT",PAT,9999999-WHEN,DGRP,DA,NEXT)=""
- +19 IF PAT
- SET ^OR(100,"AC",PAT,9999999-WHEN,DA,NEXT)=""
- +20 IF SIG
- SET ^OR(100,"AS",PAT,9999999-WHEN,DA,NEXT)=""
- +21 if $LENGTH($GET(REASON))
- SET ^OR(100,DA,8,NEXT,1)=REASON
- +22 SET $PIECE(HDR,U,3,4)=NEXT_U_TOTAL
- SET ^OR(100,DA,8,0)=HDR
- +23 QUIT NEXT
- +24 ;
- 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