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

ORCSAVE2.m

Go to the documentation of this file.
  1. ORCSAVE2 ;SLC/MKB-Utilities to update an order ;Jun 03, 2020@15:21:13
  1. ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,27,56,70,94,116,190,157,215,265,243,293,280,346,269,421,382,377,405**;Dec 17, 1997;Build 211
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ;Nov 12, 2015 PB - modified to do a sync for a saved order
  1. ;
  1. STATUS(IFN,ST) ; -- Update status of order
  1. Q:'$G(IFN) Q:'$D(^OR(100,+IFN,0)) Q:$P($G(^(3)),U,3)=$G(ST) ;no change
  1. Q:'$G(ST) Q:'$D(^ORD(100.01,+ST,0))
  1. N NODE0,NODE3,ORNOW,DA,XACT,PROV,ORVP
  1. S NODE3=$G(^OR(100,+IFN,3)),ORVP=$P($G(^(0)),U,2),ORNOW=$$NOW^XLFDT
  1. S $P(NODE3,U)=ORNOW,$P(NODE3,U,3)=ST,^OR(100,+IFN,3)=NODE3
  1. I (ST<3)!(ST=12)!(ST=13),$G(ORDCNTRL)'="ZC" D DATES(+IFN,,+$E(ORNOW,1,12))
  1. I "^1^2^7^12^13^15^"[(U_ST_U) D CANCEL^ORCSEND(+IFN),UNOTIF^ORCSIGN
  1. I $P(NODE3,U,9) D CKPARENT($P(NODE3,U,9)) ; ck siblings to update parent
  1. D SETALL^ORDD100(+IFN)
  1. Q
  1. ;
  1. CKPARENT(ORIFN) ; -- Update status of parent order, if appropriate
  1. N ORSTS,ALLRELSD,ALLDONE,DC,COMP,CH,CHSTS,ACTIVE,LAPS
  1. Q:'$D(^OR(100,ORIFN,0)) S ORSTS=$P($G(^(3)),U,3)
  1. I (ORSTS=11)!(ORSTS=10) S ALLRELSD=1 D Q ;Parent unrel'd - ck children
  1. . F CH=0:0 S CH=$O(^OR(100,ORIFN,2,CH)) Q:CH'>0 D Q:'ALLRELSD
  1. . . I '$D(^OR(100,CH)) K ^OR(100,ORIFN,2,CH) Q
  1. . . S CHSTS=$P($G(^OR(100,CH,3)),U,3) S:CHSTS=11 ALLRELSD=0
  1. . I ALLRELSD D STATUS(ORIFN,5) ; update Parent order to pending
  1. S ALLDONE=1,(DC,COMP,LAPS,ACTIVE)=0
  1. F CH=0:0 S CH=$O(^OR(100,ORIFN,2,CH)) Q:CH'>0 D Q:'ALLDONE
  1. . I '$D(^OR(100,CH)) K ^OR(100,ORIFN,2,CH) Q
  1. . S CHSTS=$P($G(^OR(100,CH,3)),U,3) I CHSTS=14 S LAPS=1 Q
  1. . I "^1^12^13^"[(U_CHSTS_U) S DC=1 Q
  1. . I "^2^7^"[(U_CHSTS_U) S COMP=1 Q
  1. . S ALLDONE=0 S:CHSTS=6 ACTIVE=1
  1. I ALLDONE S ORSTS=$S(COMP:2,DC:1,LAPS:14,1:"") D:ORSTS STATUS(ORIFN,ORSTS) Q
  1. I ACTIVE,ORSTS'=6 D STATUS(ORIFN,6) ;at least child active
  1. Q
  1. ;
  1. RELEASE(ORDER,ACTION,WHEN,WHO,NATURE) ; -- Mark order as released to service
  1. S:'$G(ACTION) ACTION=1 S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) S:'$G(WHO) WHO=DUZ
  1. Q:'$G(ORDER) N OR0 S OR0=$G(^OR(100,ORDER,8,ACTION,0))
  1. S:$L($G(NATURE)) $P(OR0,U,12)=$S(NATURE:NATURE,1:+$O(^ORD(100.02,"C",NATURE,0)))
  1. S:($P(OR0,U,15)=10)!($P(OR0,U,15)=11) $P(OR0,U,15)=""
  1. ;S $P(OR0,U,16,17)=WHEN_U_WHO,^OR(100,"AR",ORVP,9999999-WHEN,ORDER,ACTION)=""
  1. S $P(OR0,U,16,17)=WHEN_U_WHO
  1. S ^OR(100,ORDER,8,ACTION,0)=OR0
  1. D FIXRAD(ORDER,$P(OR0,U,2))
  1. I $P(OR0,U,2)="NW",'$P(^OR(100,ORDER,0),U,8) D STARTDT(ORDER)
  1. ;Set the "AR" index.
  1. D RS^ORDD100(ORDER,ACTION,ORVP,WHEN)
  1. Q
  1. ;
  1. FIXRAD(DA,TYPE) ; -- Fix Radiology Orders with start dates that are no longer valid
  1. Q:'$G(DA)!('$D(^OR(100,DA,0)))
  1. I $P($G(^OR(100,DA,4)),U)'="" Q
  1. N TODAY,START,ORDG,ORDLGS,RADINFO,I,STARTFM,TODAYEXT
  1. D IMTYPSEL^ORWDRA32(.RADINFO)
  1. S ORDLGS="^XRAY^",I=0
  1. F S I=$O(RADINFO(I)) Q:'I S ORDLGS=ORDLGS_$P(RADINFO(I),U,3)_U
  1. S ORDG=$P($G(^ORD(100.98,+$P(^OR(100,DA,0),U,11),0)),U,3)
  1. Q:'(ORDLGS[(U_ORDG_U)) ; Not a radiology order
  1. S START=$$VALUE(DA,"START"),TODAY=$$DT^XLFDT
  1. D DT^ORWU(.STARTFM,START) S STARTFM=$P(STARTFM,".")
  1. Q:STARTFM'<TODAY
  1. S TODAYEXT=$$FMTE^XLFDT(TODAY)
  1. D RESP(DA,"OR GTX START DATE",TODAYEXT)
  1. I TYPE="NW",$P(^OR(100,DA,0),U,8)=STARTFM D
  1. . N FDA,ERROR
  1. . S FDA(100,DA_",",21)=TODAY
  1. . D FILE^DIE("","FDA","ERROR")
  1. Q
  1. ;
  1. STARTDT(DA) ; -- resolve Start and Stop dates from Responses
  1. N X,Y,%DT,ORDG,ORT,ORLAB
  1. S ORDG=$P($G(^ORD(100.98,+$P(^OR(100,DA,0),U,11),0)),U,3)
  1. S ORLAB="^LAB^CH^HEMA^MI^AP^AU^EM^SP^CY^BB^"[(U_ORDG_U),ORT=""
  1. S:ORDG="E/L T" ORT=$$VALUE(DA,"TIME") S:ORDG="MEAL" ORT=$$MEALTIME^ORCDFHO(DA)
  1. STRT S X=$$VALUE(DA,"START") I '$L(X) D WS^ORDD100 Q S:$L(ORT) X=X_"@"_ORT
  1. D AM:X="AM",NEXT:X="NEXT",ADMIN("NEXT"):X="NEXTA",ADMIN("CLOSEST"):X="CLOSEST"
  1. S %DT="T" D ^%DT Q:Y'>0 S:$E($P(Y,".",2),1,2)=24 Y=$P(Y,".")_".2359"
  1. S $P(^OR(100,DA,0),U,8)=Y D SS^ORDD100,WS^ORDD100,OI1^ORDD100A(DA)
  1. STOP I ORLAB S X=$$VALUE(DA,"DAYS") Q:X'>1 S X=$$FMADD^XLFDT(Y,(X-1))
  1. I 'ORLAB S X=$$VALUE(DA,"STOP") Q:'$L(X) S:$L(ORT) X=X_"@"_ORT
  1. S %DT="T" D ^%DT Q:Y'>0 S:$E($P(Y,".",2),1,2)=24 Y=$P(Y,".")_".2359"
  1. S $P(^OR(100,DA,0),U,9)=Y D ES^ORDD100A
  1. Q
  1. ;
  1. NEXT ; -- Resolve next lab collection to FM date/time
  1. N ORTIME,ORDAY,NOW,NEXT,ENT
  1. ;is referenced by DBIA #964
  1. S ENT=$S($P($G(^SC(+$G(ORL),0)),U,4):+$P(^(0),U,4),1:+$G(DUZ(2)))_";DIC(4," S:ENT'>0 ENT="ALL"
  1. D GETLST^XPAR(.ORTIME,ENT,"LR PHLEBOTOMY COLLECTION","N")
  1. S NOW=$P($H,",",2),ORDAY=$S($O(ORTIME(NOW)):"T",1:"T+1")
  1. S ORDAY=$$NEXTCOLL^ORCDLR1(ORDAY) S:ORDAY["+" NOW=0
  1. S NEXT=$O(ORTIME(NOW)),X=ORDAY_"@"_$P($G(ORTIME(+NEXT)),U)
  1. Q
  1. ;
  1. AM ; -- Resolve AM lab collection to FM date/time
  1. N ORTIME,ORDAY,AM,NOW,ENT
  1. ;is referenced by DBIA #964
  1. S ENT=$S($P($G(^SC(+$G(ORL),0)),U,4):+$P(^(0),U,4),1:+$G(DUZ(2)))_";DIC(4," S:ENT'>0 ENT="ALL"
  1. D GETLST^XPAR(.ORTIME,ENT,"LR PHLEBOTOMY COLLECTION","N")
  1. S AM=$O(ORTIME(0)),NOW=$P($H,",",2)
  1. S ORDAY=$S(AM=$O(ORTIME(NOW)):"T",1:"T+1")
  1. S X=$$NEXTCOLL^ORCDLR1(ORDAY)_"@"_$P($G(ORTIME(+AM)),U)
  1. Q
  1. ;
  1. ADMIN(START) ; -- Resolve next/closest administration times to FM date/time
  1. N PAT,SCH,OI,LOC,Y,I
  1. I $G(DA) D ;get data from order DA
  1. . S PAT=+$P($G(^OR(100,DA,0)),U,2),LOC=""
  1. . S I=+$O(^OR(100,DA,4.5,"ID","INSTR",0)),I=+$P($G(^OR(100,DA,4.5,I,0)),U,3) ;first
  1. . S SCH=$$VALUE(DA,"SCHEDULE",I),OI=$$VALUE(DA,"ORDERABLE")
  1. I '$G(DA) D ;or look in ORDIALOG() instead
  1. . S I=+$O(ORDIALOG($$PTR^ORCD("OR GTX INSTRUCTIONS"),0))
  1. . S PAT=$G(ORVP),SCH=$G(ORDIALOG($$PTR^ORCD("OR GTX SCHEDULE"),I))
  1. . S OI=$G(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1)),LOC=""
  1. S OI=+$P($G(^ORD(101.43,+OI,0)),U,2) ;PSOI
  1. ;is referenced by DBIA #3167
  1. S Y=$$RESOLVE^PSJORPOE(PAT,SCH,OI,START,LOC),X=$P(Y,U,2)
  1. Q
  1. ;
  1. SIGN(DA,WHO,WHEN,HOW,WHAT) ; -- affix ES to order
  1. Q:'$G(DA) S:'$G(WHAT) WHAT=1
  1. N X S X=$G(^OR(100,DA,8,WHAT,0)) D S2^ORDD100(DA,WHAT) ; kill AS xref
  1. S $P(X,U,4,7)=$G(HOW)_U_$G(WHO)_U_$E($G(WHEN),1,12)_U_$S(HOW=0:DUZ,1:"")
  1. ; S:$G(WHO) $P(X,U,3)=WHO ; reset provider to signer
  1. S ^OR(100,DA,8,WHAT,0)=X
  1. D:$G(HOW)=2 S1^ORDD100(DA,WHAT) ; reset AS xref
  1. Q
  1. ;
  1. SIGSTS(IFN,ACT) ; -- Set SigSts for backdoor orders [Called from ^ORM* rtns]
  1. ; Expects ORNATR, ORVP, ORNP to be defined
  1. Q:'$G(IFN) Q:'$G(ACT) N X,OR0 S OR0=+$P($G(^OR(100,+IFN,8,ACT,0)),U)
  1. S X=$S($$SIGNREQD^ORCACT1(+IFN):$$SIGSTS^ORX1(ORNATR),1:3)
  1. K ^OR(100,"AS",ORVP,9999999-OR0,+IFN,ACT)
  1. S $P(^OR(100,+IFN,8,ACT,0),U,4)=X
  1. I X=2 S ^OR(100,"AS",ORVP,9999999-OR0,+IFN,ACT)="" D NOTIF^ORCSIGN
  1. Q
  1. ;
  1. UNVEIL(IFN) ; -- unveil new order
  1. S $P(^OR(100,IFN,3),U,8)=""
  1. Q
  1. ;
  1. DELETE(ORDER) ; -- delete order [action]
  1. ;no longer delete, only cancel
  1. D CANCEL^ORCSAVE2(ORDER)
  1. Q
  1. ;
  1. VERIFY(IFN,DA,TYPE,WHO,WHEN) ; -- order verified
  1. Q:'$G(IFN) Q:'$G(DA) Q:"^N^C^R^"'[(U_$G(TYPE)_U)
  1. I $G(^TMP($J,"OR MOB APP"))="CPRS" Q
  1. N FLD S FLD=$S(TYPE="N":8,TYPE="C":10,1:18)
  1. S:'$G(WHO) WHO=DUZ S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12)
  1. S $P(^OR(100,IFN,8,DA,0),U,FLD,FLD+1)=WHO_U_WHEN
  1. D:$L($T(VER^EDPFMON)) VER^EDPFMON(IFN)
  1. Q
  1. ;
  1. COMP(IFN,WHO,WHEN) ; -- order completed
  1. Q:'$G(IFN) S:'$G(WHO) WHO=DUZ S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12)
  1. D DATES(+IFN,,WHEN),STATUS(+IFN,2)
  1. S $P(^OR(100,+IFN,6),U,6,7)=WHEN_U_WHO
  1. D:$L($T(COMP^EDPFMON)) COMP^EDPFMON(IFN)
  1. Q
  1. ;
  1. DATES(DA,START,STOP) ; -- Update start/stop dates for order DA
  1. Q:'$G(DA) I $G(START) D
  1. . Q:START=$P(^OR(100,DA,0),U,8)
  1. . D SK^ORDD100,WK^ORDD100,OI2^ORDD100A(DA)
  1. . S $P(^OR(100,DA,0),U,8)=START
  1. . D SS^ORDD100,WS^ORDD100,OI1^ORDD100A(DA)
  1. I $G(STOP) D
  1. . ;Q:STOP=$P(^OR(100,DA,0),U,9) ;ck xref anyway
  1. . D EK^ORDD100A S $P(^OR(100,DA,0),U,9)=STOP D ES^ORDD100A
  1. Q
  1. ;
  1. OC ; -- Save order checks in ORCHECK() in ^OR(100,+ORIFN,9) ON SIGNATURE IN CPRS
  1. Q:'$G(ORIFN) Q:'$D(^OR(100,+ORIFN,0))
  1. D DELOCC^OROCAPI1(+ORIFN,"SIGNATURE_CPRS")
  1. N I,J,ORK,CNT,OC,OROCRET,ORKI,ORCROC
  1. S CNT=0
  1. S I=0 F S I=$O(ORCHECK(+ORIFN,I)) Q:'I D
  1. . S J=0 F S J=$O(ORCHECK(+ORIFN,I,J)) Q:'J D
  1. . . S OC=ORCHECK(+ORIFN,I,J)
  1. . . S CNT=CNT+1
  1. . . S ORK(CNT,1)=+ORIFN_U_"SIGNATURE_CPRS"_U_DUZ_U_$$NOW^XLFDT_U_+OC_U_I
  1. . . S ORK(CNT,2,1)=$P(OC,U,3)
  1. . . ;TDP - Modified to handle ORREASONS input
  1. . . S ORK(CNT,3)=$S(((I=1)&($G(ORCHECK("OK")))):$G(ORCHECK("OK")),$D(ORREASONS(+ORIFN)):$G(ORREASONS(+ORIFN)),1:"")
  1. . . ;TDP - Modified to accept ORCOMMENTS
  1. . . S ORK(CNT,4)=$S($D(ORCOMMENTS(+ORIFN)):$G(ORCOMMENTS(+ORIFN)),1:"")
  1. . . I $E(ORK(CNT,2,1),0,2)="||" D
  1. . . . N ORGLOB,ORRULE,ORI,ORICNT
  1. . . . S ORGLOB=$P($P(ORK(CNT,2,1),"||",2),"&"),ORRULE=$P($P(ORK(CNT,2,1),"||",2),"&",2)
  1. . . . S ORCROC(CNT)=$P($P(ORK(CNT,2,1),"||",2),"&",3)_U_$P($P(ORK(CNT,2,1),"||",2),"&",4)
  1. . . . S ORK(CNT,2,1)=ORRULE,ORICNT=2,ORI=1
  1. . . . F S ORI=$O(^TMP($J,"ORK XTRA TXT",ORGLOB,ORRULE,ORI)) Q:'ORI S ORK(CNT,2,ORICNT)=^TMP($J,"ORK XTRA TXT",ORGLOB,ORRULE,ORI),ORICNT=ORICNT+1
  1. I $D(ORK) D
  1. . D SAVEOC^OROCAPI1(.ORK,.OROCRET)
  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(OROCRET(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(OROCRET(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. Q
  1. ;
  1. VALUE(IFN,ID,INST) ; -- Returns value of prompt by identifier ID
  1. I '$G(IFN)!('$D(^OR(100,+$G(IFN),0)))!($G(ID)="") Q ""
  1. N I,Y S I=0,Y="" S:'$G(INST) INST=1
  1. F S I=$O(^OR(100,IFN,4.5,"ID",ID,I)) Q:I'>0 I $P($G(^OR(100,IFN,4.5,+I,0)),U,3)=INST S Y=$G(^(1)) Q
  1. Q Y
  1. ;
  1. SC(ORX,ORIFN) ; -- save responses to SC questions
  1. Q:'$G(ORIFN) Q:'$D(^OR(100,+ORIFN,0)) ;invalid order number
  1. N OR5,I,P S OR5=$G(^OR(100,+ORIFN,5)),P=0
  1. F I="SC","MST","AO","IR","EC","HNC","CV","SHD" S P=P+1 S:$D(ORX(I)) $P(OR5,U,P)=ORX(I)
  1. S ^OR(100,+ORIFN,5)=OR5
  1. Q
  1. ;
  1. CANCEL(ORDER) ; -- cancel order [action]
  1. N ORA,DIE,DA,DR,ORX
  1. S ORDER=$G(ORDER),ORA=+$P(ORDER,";",2) Q:'ORA!('ORDER)
  1. I $D(^OR(100,+ORDER,8,ORA)) D
  1. .S ORX="Unsigned/unreleased order cancelled by provider"
  1. .S DIE="^OR(100,"_+ORDER_",8,",DA=ORA,DA(1)=+ORDER
  1. .S DR="4////5;15////13;1////^S X=ORX" D ^DIE
  1. I ORA=1 D
  1. .K DA S DIE="^OR(100,",DA=+ORDER,DR="5////13" D ^DIE
  1. Q
  1. ;
  1. LAPSE(ORDER) ; -- lapse order [action]
  1. N ORA S ORA=+$P(ORDER,";",2)
  1. Q:'$D(^OR(100,+ORDER,0)) Q:'ORA!('ORDER)
  1. I $D(^OR(100,+ORDER,8,ORA)) D
  1. .N DIE,DA,DR
  1. .S DIE="^OR(100,"_+ORDER_",8,",DA=ORA,DA(1)=+ORDER
  1. .S DR="4////5;15////14" D ^DIE,DELALRT^ORCSAVE1(ORDER) ; DELALRT call added to fix CQ #17536 (TC). [v28.1]
  1. I ORA=1 D
  1. .N DIE,DA,DR
  1. .S DIE="^OR(100,",DA=+ORDER,DR="5////14"
  1. .D ^DIE,ALPS(DA,ORA)
  1. Q
  1. ALPS(DA,ORACT,TYPE) ;set the lapse index ^OR(100,"ALPS")
  1. N ORVP,X,OR0,ORLOG
  1. S OR0=$G(^OR(100,DA,8,ORACT,0))
  1. S ORLOG=$P(OR0,U),ORVP=$P($G(^OR(100,DA,0)),U,2)
  1. I ORVP,ORLOG S ^OR(100,"ALPS",ORVP,9999999-ORLOG,DA,ORACT)=$G(TYPE)
  1. S ^OR(100,DA,10)=$$NOW^XLFDT
  1. Q
  1. ;
  1. RESP(IFN,PRMT,VAL,INST) ; -- update a single Response VALue
  1. S IFN=+$G(IFN),VAL=$G(VAL),PRMT=+$O(^ORD(101.41,"AB",PRMT,0))
  1. N ID,DA,DIK S:'$G(INST) INST=1
  1. S ID=$P($G(^ORD(101.41,PRMT,1)),U,3) Q:'$L(ID)
  1. S DA=0 F S DA=$O(^OR(100,IFN,4.5,"ID",ID,DA)) Q:DA<1 Q:$P($G(^OR(100,IFN,4.5,DA,0)),U,3)=INST
  1. I 'DA D:$L(VAL) Q ;add
  1. . N DO,DIC,DLG,X
  1. . S DIC="^OR(100,"_IFN_",4.5,",DA(1)=IFN,DIC(0)="FL"
  1. . S DIC("DR")=".02///"_PRMT_";.03///"_INST_";.04///"_ID
  1. . S DLG=+$P($G(^OR(100,IFN,0)),U,5)
  1. . S X=+$O(^ORD(101.41,DLG,10,"D",PRMT,0))
  1. . D FILE^DICN S:Y ^OR(100,IFN,4.5,+Y,1)=VAL
  1. I $L(VAL) S ^OR(100,IFN,4.5,DA,1)=VAL Q ;change
  1. S DIK="^OR(100,"_IFN_",4.5,",DA(1)=IFN D ^DIK ;delete
  1. Q