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