Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ORCSAVE

ORCSAVE.m

Go to the documentation of this file.
  1. 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
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ; DBIA 10103 ^XLFDT
  1. ;
  1. NEW(ORDIALOG,ORDG,ORPKG,ORCAT,OREVENT,ORDUZ,ORLOG) ; -- New order
  1. ; Returns ORIFN = [new] order number, if created/saved
  1. D EN
  1. Q
  1. ;
  1. XX ; -- save new/unreleased edited order into Orders file
  1. ; Requires: ORDIALOG() = array of dialog values
  1. ; ORIFN = IFN of original order that was edited
  1. ;
  1. D ORCAN^ORNORC(+ORIFN,"CH") ; ajb *377
  1. N OLDIFN S ORIFN=+ORIFN,OLDIFN=0
  1. 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
  1. D EN Q:'ORIFN S:'$G(ORDA) ORDA=1
  1. I $G(OLDIFN) D ;save links between orders
  1. . S $P(^OR(100,ORIFN,3),U,5)=OLDIFN,$P(^(3),U,11)=1
  1. . S $P(^OR(100,OLDIFN,3),U,6)=ORIFN S:$D(^(5)) ^OR(100,ORIFN,5)=^OR(100,OLDIFN,5)
  1. I $D(^OR(100,+OLDIFN,0)) D
  1. . Q:'$G(OREVTDF)
  1. . N OLDEVT,OLDSTS,LSTACT,PATID,NOW,WHEN
  1. . S (OLDEVT,OLDSTS,LSTACT)=0
  1. . S NOW=$$NOW^XLFDT
  1. . S OLDEVT=$P(^OR(100,+OLDIFN,0),U,17),OLDSTS=$P(^OR(100,+OLDIFN,3),U,3)
  1. . ; Active status = 6 from #100.01
  1. . I (OLDEVT>0),OLDSTS=6 D
  1. . . S $P(^OR(100,+ORIFN,0),U,17)=OLDEVT
  1. . . S $P(^OR(100,+ORIFN,3),U,3)=11
  1. . . S LSTACT=$P($G(^OR(100,+ORIFN,3)),U,7)
  1. . . I $D(^OR(100,+ORIFN,8,LSTACT,0)) D
  1. . . . S $P(^OR(100,+ORIFN,8,LSTACT,0),U,15)=11
  1. . . . S PATID=$P(^OR(100,+ORIFN,0),U,2)
  1. . . . S WHEN=$P(^OR(100,+ORIFN,8,LSTACT,0),U)
  1. . . . S ^OR(100,"AC",PATID,9999999-WHEN,+ORIFN,LSTACT)=""
  1. Q
  1. ;
  1. RN ; -- save new/unreleased renewal order into Orders file
  1. ; Requires: ORDIALOG() = array of new dialog values
  1. ; ORIFN = IFN of original order that was renewed
  1. ;
  1. N OLDIFN S OLDIFN=+ORIFN K ORIFN
  1. D EN Q:'ORIFN S:'$G(ORDA) ORDA=1
  1. S $P(^OR(100,ORIFN,3),U,5)=OLDIFN,$P(^(3),U,11)=2
  1. S $P(^OR(100,OLDIFN,3),U,6)=ORIFN S:$D(^(5)) ^OR(100,ORIFN,5)=^OR(100,OLDIFN,5)
  1. Q
  1. ;
  1. EN ; -- save new/unreleased order in ORDIALOG() into Orders file
  1. ; Requires: ORVP, ORNP [and ORL, ORTS, ORAPPT if available]
  1. ; If defined: ORCAT,ORPKG,ORDG,ORLOG,ORDUZ,OREVENT,ORDCNTRL,ORSRC
  1. ; (else use values from ORDIALOG and current state)
  1. ;
  1. N PKG,NOW,NODE,CNT,CDL,I,X,STS,SIGNREQD,LOC,TRSPEC,NATR,CATG,DG,LOG,USR,TYPE,ORK,ORCSORD
  1. Q:'$G(ORVP) Q:'$G(ORDIALOG) Q:'$D(^ORD(101.41,+ORDIALOG,0))
  1. S NOW=$$NOW^XLFDT,SIGNREQD=+$P(^ORD(101.41,+ORDIALOG,0),U,6)
  1. S CATG=$S($L($G(ORCAT)):ORCAT,1:$S($$INPT^ORCD:"I",1:"O"))
  1. S PKG=$S($G(ORPKG):ORPKG,1:$P(^ORD(101.41,+ORDIALOG,0),U,7))
  1. S LOG=$S($G(ORLOG):ORLOG,1:+$E(NOW,1,12)),USR=$S($G(ORDUZ):ORDUZ,1:DUZ)
  1. I $G(ORIFN),$D(^OR(100,ORIFN,0)) S STS=$P(^(3),U,3) G EN2 ; unrel order
  1. S DG=$S($G(ORDG):+ORDG,1:$P(^ORD(101.41,+ORDIALOG,0),U,5))
  1. I $G(OREVENT),"^PSO^RA^"'["^"_$$GET1^DIQ(9.4,+PKG_",",1)_"^",'$G(DGPMT) S LOC="",TRSPEC="" ; p286 added radiology package
  1. E S LOC=$G(ORL),TRSPEC=$G(ORTS)
  1. S TYPE=$S("^B^C^X^P^0^"[(U_$G(ORSRC)_U):ORSRC,$G(ORDCNTRL)="SN":"P",1:0)
  1. ;S LOG=$S($G(ORLOG):ORLOG,1:+$E(NOW,1,12)),USR=$S($G(ORDUZ):ORDUZ,1:DUZ) moved up before EN2 call
  1. S NATR=+$O(^ORD(100.02,"C","E",0)) ;assume Elec Entered until changed
  1. S STS=$S($G(OREVENT):10,1:11),ORIFN=$$NEXTIFN Q:'ORIFN
  1. 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)
  1. S ^OR(100,ORIFN,3)=LOG_"^90^"_STS_U_$S($G(ORIT):ORIT_";ORD(101.41,",1:"")_U_$G(ORDIALOG("PREV"))_"^^1^^^^"_TYPE
  1. 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)=""
  1. ;Indication for use
  1. I $G(INDICAT)'="" S $P(^OR(100,ORIFN,10),U,2)=INDICAT
  1. S ^OR(100,"AF",LOG,ORIFN,1)=""
  1. ; RBD OR*3.0*453 Add setting of EPRACDT index explicitly
  1. I $G(ORNP)]"" S ^OR(100,"EPRACDT",ORNP,LOG,ORIFN,1)=""
  1. S ^OR(100,"C",+ORDIALOG_";ORD(101.41,",ORIFN)="" ;patch 423
  1. S:+$G(ORIT) ^OR(100,"D",+ORIT_";ORD(101.41,",ORIFN)="" ;patch 423
  1. I $G(ORSLDEA)]"" S $P(^OR(100,ORIFN,11.1),U)=ORSLDEA ;patch 499
  1. S ^OR(100,"ACT",ORVP,9999999-LOG,+DG,ORIFN,1)=""
  1. S:STS'=10 ^OR(100,"AC",ORVP,9999999-LOG,ORIFN,1)=""
  1. S:SIGNREQD ^OR(100,"AS",ORVP,9999999-LOG,ORIFN,1)=""
  1. S:$G(OREVENT) ^OR(100,"AEVNT",ORVP,OREVENT,ORIFN)=""
  1. ;check if OR GTX STUDY REASON is in ORDIALOG and strip out control characters
  1. N ORRFSID
  1. S ORRFSID=$O(^ORD(101.41,"B","OR GTX STUDY REASON",""))
  1. I ORRFSID,$D(ORDIALOG(ORRFSID,1)) D
  1. .N X,I
  1. .S X=ORDIALOG(ORRFSID,1)
  1. .F I=1:1:31 S X=$TR(X,$C(I))
  1. .S ORDIALOG(ORRFSID,1)=X
  1. EN2 S ORIFN=+ORIFN D RESPONSE ; save responses
  1. I $P(^OR(100,ORIFN,0),"^",5) D ;Copy orders PKI fix
  1. . N OI,ORPKIU
  1. . S OI=+$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",0)),OI=+$G(^OR(100,ORIFN,4.5,OI,1)) Q:'OI
  1. . I PKG'=$O(^DIC(9.4,"B","OUTPATIENT PHARMACY",0)) Q
  1. . S ORPKIU=0 I $D(^ORD(100.7,"C",DUZ)) S ORPKIU=1
  1. . D PKI^ORWDPS1(.ORY,OI,CATG,+ORVP,ORPKIU)
  1. . I $E($G(ORY))=2 S ORDEA=ORY
  1. ;
  1. ; Update: Order Text, External Text, Drug Schedule, Digital Sig Required
  1. I $G(^OR(100,ORIFN,8,1,2))'="" S $P(^OR(100,ORIFN,8,1,2),"^",4,5)="^"
  1. K ^OR(100,ORIFN,8,1,.2)
  1. K ^OR(100,ORIFN,8,1,.1)
  1. D ORDTEXT^ORCSAVE1(ORIFN_";1")
  1. ;
  1. S NODE=$G(^OR(100,ORIFN,8,1,0)) D S ^OR(100,ORIFN,8,1,0)=NODE
  1. . S $P(NODE,U,3)=$G(ORNP)
  1. . S $P(NODE,U,13)=USR
  1. S NODE=$G(^OR(100,ORIFN,0)) D S ^OR(100,ORIFN,0)=NODE
  1. . S $P(NODE,U,4)=$G(ORNP)
  1. . S I=$O(^OR(100,ORIFN,4.5,"ID","LOCATION",0))
  1. . 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
  1. . S I=$O(^OR(100,ORIFN,4.5,"ID","CLASS",0))
  1. . I I S X=$G(^OR(100,ORIFN,4.5,+I,1)) S:"^I^O^"[(U_X_U) $P(NODE,U,12)=X
  1. S $P(^OR(100,ORIFN,3),U)=NOW
  1. ;Audit certain fields for CS ePCS Order so that we have an audit of changes to unsigned CS orders.
  1. S ORCSORD=""
  1. D CSVALUE^ORDEA(.ORCSORD,ORIFN)
  1. I ORCSORD D AUDORDXX^ORDEA(ORIFN)
  1. ;
  1. D DELOCC^OROCAPI1(ORIFN,"ACCEPTANCE_CPRS")
  1. I $G(ORCHECK) D ; save order checks
  1. . N ORCROC
  1. . S (CNT,CDL)=0 F S CDL=$O(ORCHECK("NEW",CDL)) Q:CDL'>0 S I=0 D
  1. . . F S I=$O(ORCHECK("NEW",CDL,I)) Q:I'>0 D
  1. . . . I $D(ORCHECK("NEW",CDL,I,0)) D
  1. . . . . 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)
  1. . . . S X=ORCHECK("NEW",CDL,I)
  1. . . . S ORK(I,1)=+ORIFN_U_"ACCEPTANCE_CPRS"_U_DUZ_U_$$NOW^XLFDT_U_$P(X,U)_U_CDL
  1. . . . S ORK(I,2,1)=$P(X,U,3)
  1. . . . I $E(ORK(I,2,1),0,2)="||" D
  1. . . . . N ORGLOB,ORRULE,ORI,ORLINE
  1. . . . . S ORGLOB=$P($P(ORK(I,2,1),"||",2),"&"),ORRULE=$P($P(ORK(I,2,1),"||",2),"&",2)
  1. . . . . S ORCROC(I)=$P($P(ORK(I,2,1),"||",2),"&",3)_U_$P($P(ORK(I,2,1),"||",2),"&",4)
  1. . . . . S ORK(I,2,1)=ORRULE,ORI=0,ORLINE=2
  1. . . . . 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
  1. . . . S ORK(I,3)=$G(ORCHECK("NEW",CDL,I,"OVER"))
  1. . . . S ORK(I,4)=$G(ORCHECK("NEW",CDL,I,"REMCOMM"))
  1. . I $D(ORK) D
  1. . . N OCRET,ORKI
  1. . . D SAVEOC^OROCAPI1(.ORK,.OCRET)
  1. . . I $D(ORCROC) D
  1. . . . N ORCROCI S ORCROCI=0 F S ORCROCI=$O(ORCROC(ORCROCI)) Q:'ORCROCI D
  1. . . . . N OCINST S OCINST=$O(OCRET(ORCROCI,"")) Q:'OCINST D
  1. . . . . . S ^ORD(100.05,OCINST,12)=ORCROC(ORCROCI)
  1. . . S ORKI=0 F S ORKI=$O(ORK(ORKI)) Q:'ORKI D
  1. . . . N OCINST,OCTXT S OCTXT=$G(ORK(ORKI,2,1))
  1. . . . S OCINST=$O(OCRET(ORKI,0))
  1. . . . N ORMONOI,ORMONOQ S ORMONOI=0,ORMONOQ=0 F Q:ORMONOQ=1 S ORMONOI=$O(^TMP($J,"ORMONOGRAPH",ORMONOI)) Q:'ORMONOI D
  1. . . . . I OCTXT[$G(^TMP($J,"ORMONOGRAPH",ORMONOI,"OC")) D
  1. . . . . . S ORMONOQ=1
  1. . . . . . S ^ORD(100.05,OCINST,17)=^TMP($J,"ORMONOGRAPH",ORMONOI,"INT")
  1. . . . . . M ^ORD(100.05,OCINST,16)=^TMP($J,"ORMONOGRAPH",ORMONOI,"DATA")
  1. . . . . . 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
  1. . . K ^TMP($J,"ORMONOGRAPH")
  1. . . K ^TMP($J,"ORK XTRA TXT")
  1. K ORDEA
  1. ENQ Q
  1. ;
  1. NEXTIFN() ; -- Returns next available ORIFN
  1. N I,HDR,LAST,TOTAL,DA
  1. L +^OR(100,0):$S($G(DILOCKTM)>0:DILOCKTM,1:5)
  1. I '$T Q "^"
  1. S HDR=$G(^OR(100,0)),TOTAL=+$P(HDR,U,4),LAST=$O(^OR(100,"?"),-1)
  1. S I=LAST\1 F I=(I+1):1 Q:'$D(^OR(100,I,0))
  1. S DA=I,^OR(100,DA,0)=DA,$P(HDR,U,3,4)=DA_U_(TOTAL+1)
  1. S ^OR(100,0)=HDR L -^OR(100,0)
  1. Q DA
  1. ;
  1. RESPONSE ; -- Save responses in ORDIALOG() into ^OR(100,ORIFN,4.5)
  1. N PROMPT,CNT,ITM,TYPE,INST,VALUE,I,START,PAT,X
  1. S PAT=$P(^OR(100,ORIFN,0),U,2),START=$P(^(0),U,8) K ^(4.5)
  1. S (PROMPT,CNT)=0 F S PROMPT=$O(ORDIALOG(PROMPT)) Q:PROMPT'>0 D
  1. . S ITM=$G(ORDIALOG(PROMPT)) Q:'ITM
  1. . S TYPE=$E($G(ORDIALOG(PROMPT,0))) Q:'$L(TYPE)
  1. . S INST=0 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0 D
  1. . . S VALUE=$G(ORDIALOG(PROMPT,INST)) Q:VALUE="" S CNT=CNT+1
  1. . . S ^OR(100,ORIFN,4.5,CNT,0)=+ITM_U_PROMPT_U_INST_U_$P(ITM,U,2)
  1. . . S:$L($P(ITM,U,2)) ^OR(100,ORIFN,4.5,"ID",$P(ITM,U,2),CNT)=""
  1. . . I VALUE<1,TYPE="N" S VALUE=0_+VALUE I VALUE="00" S VALUE=0
  1. . . S:TYPE'="W" ^OR(100,ORIFN,4.5,CNT,1)=VALUE
  1. . . M:TYPE="W" ^OR(100,ORIFN,4.5,CNT,2)=@VALUE ; array root
  1. S ^OR(100,ORIFN,4.5,0)="^100.045A^"_CNT_U_CNT
  1. R1 ; [Reset] Orderables
  1. 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
  1. K ^OR(100,ORIFN,.1) I $D(^OR(100,ORIFN,4.5,"ID","ORDERABLE")) D
  1. . S (I,CNT)=0
  1. . F S I=$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",I)) Q:I'>0 D
  1. . . S X=$G(^OR(100,ORIFN,4.5,I,1)) Q:'X
  1. . . S CNT=CNT+1,^OR(100,ORIFN,.1,CNT,0)=X,^OR(100,ORIFN,.1,"B",X,CNT)=""
  1. . . I PAT,START S ^OR(100,"AOI",X,PAT,9999999-START,ORIFN)=""
  1. . S ^OR(100,ORIFN,.1,0)="^100.001PA^"_CNT_U_CNT
  1. Q
  1. ;
  1. RESUME(IFN) ; -- add Response nodes for RESUME tray service
  1. ; S ^OR(100,+IFN,4.5,<next>,0)=DT_"^^^RESUME",^(1)=1
  1. ;
  1. N X,Y,DA,DIC,DLAYGO,MSG
  1. D FIELD^DID(100,4.5,"","SPECIFIER","MSG")
  1. S DIC="^OR(100,"_+IFN_",4.5,",DIC(0)="LX",DA(1)=+IFN,X=DT
  1. S DIC("DR")=".04///RESUME",DIC("P")=$G(MSG("SPECIFIER")),DLAYGO=100
  1. D ^DIC S:Y ^OR(100,+IFN,4.5,+Y,1)=1
  1. Q
  1. ;
  1. PROVIDER(ORDER,PROV) ; -- Change PROVider assigned to ORDER
  1. Q:'$G(ORDER) Q:'$G(PROV)
  1. N ORACT S ORACT=+$P(ORDER,";",2) S:'ORACT ORACT=1
  1. S $P(^OR(100,+ORDER,8,ORACT,0),U,3)=PROV
  1. S:ORACT=1 $P(^OR(100,+ORDER,0),U,4)=PROV
  1. Q
  1. ;
  1. ACTION(CODE,DA,PROV,REASON,WHEN,WHO) ; -- save new action
  1. N NEXT,TOTAL,HDR,LAST,X,PAT,DGRP,SIG,NATR,TXT S DA=+DA
  1. Q:'$D(^OR(100,DA,0)) 0 Q:$G(CODE)'?2U 0
  1. S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) S:'$G(WHO) WHO=DUZ
  1. S NATR=+$O(^ORD(100.02,"C","E",0)) ;assume Elec Entered until changed
  1. 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))
  1. S:X'>0 X=1 S TXT=$P($G(^OR(100,DA,8,X,0)),U,14) ;current actn's txt ptr
  1. S:HDR="" HDR="^100.008DA^^" S TOTAL=+$P(HDR,U,4)
  1. S LAST=$O(^OR(100,DA,8,"C",CODE,"?"),-1) I LAST D
  1. . S X=$G(^OR(100,DA,8,LAST,0)) Q:$P(X,U,15)'=11 Q:$P(X,U,4)'=2
  1. . S NEXT=LAST I PAT,$P(X,U) D ; kill old xref entries
  1. . . K:DGRP ^OR(100,"ACT",PAT,(9999999-$P(X,U)),DGRP,DA,NEXT)
  1. . . 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)
  1. . . 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
  1. S:'$G(NEXT) NEXT=$O(^OR(100,DA,8,"?"),-1)+1,TOTAL=TOTAL+1
  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)=""
  1. S ^OR(100,"AF",WHEN,DA,NEXT)=""
  1. I $G(PROV)]"",CODE="NW" S ^OR(100,"EPRACDT",PROV,WHEN,DA,NEXT)="" ; RBD OR*3.0*453 Handle Set of EPRACDT index
  1. I PAT,DGRP S ^OR(100,"ACT",PAT,9999999-WHEN,DGRP,DA,NEXT)=""
  1. I PAT S ^OR(100,"AC",PAT,9999999-WHEN,DA,NEXT)=""
  1. I SIG S ^OR(100,"AS",PAT,9999999-WHEN,DA,NEXT)=""
  1. S:$L($G(REASON)) ^OR(100,DA,8,NEXT,1)=REASON
  1. S $P(HDR,U,3,4)=NEXT_U_TOTAL,^OR(100,DA,8,0)=HDR
  1. Q NEXT
  1. ;
  1. SET(DLG) ; -- Create new parent for order set ORDIALOG
  1. ; Returns ORPIFN = ifn of new parent order for set
  1. ;
  1. Q:'$G(ORVP) Q:'$G(DLG) N OR0,PKG,NOW,CATG,STS,ORLOC,TRSPEC,X
  1. S OR0=$G(^ORD(101.41,DLG,0)) Q:OR0="" S ORPIFN=$$NEXTIFN Q:'ORPIFN
  1. 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))
  1. I $G(OREVENT) S ORLOC="",TRSPEC=""
  1. 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)
  1. 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)=""
  1. S ^OR(100,"ACT",ORVP,9999999-NOW,ORPIFN,1)=""
  1. S:STS=11 ^OR(100,"AC",ORVP,9999999-NOW,ORPIFN,1)=""
  1. ; AEVNT ??
  1. S ^OR(100,ORPIFN,1,0)="^100.011^1^1",^(1,0)=$P(OR0,U,2) ; Order text
  1. Q