ORQRY ; SLC/MKB/JDL - Order Query utilities ;3/17/03 14:45
;;3.0;ORDER ENTRY/RESULTS REPORTING;**153,174**;Dec 17, 1997
;
;
PP(DFN,PROV) ; -- Returns 1 or 0, if PROV is prim prov for DFN
N X,Y I '$G(DFN)!'$G(PROV) Q ""
S X=$$OUTPTPR^SDUTL3(+DFN),Y=$S(+X=+PROV:1,1:0)
Q Y
;
ACT(DFN,BEG,END,LOC) ; -- Returns 1 or 0, if recent activity for DFN
; BEG = beginning date [default = DT-1yr]
; END = ending date [default = DT]
; LOC(IEN) = list of clinic IENs from #44 [default = all]
N X,YY,VASD,VAERR,IDT,DA
N VSTH,IX,JX
S DFN=+$G(DFN),YY=0 I '$G(DFN) Q ""
S BEG=$G(BEG,DT-10000),END=$G(END,DT) ;default=last year
I END<BEG S X=END,END=BEG,BEG=X
I '$D(LOC) D G:YY ACTQ ;check inpatient, Rx data
. ;curr inpt
. I $G(^DPT(DFN,.105)) S YY=1 Q
. S X=+$O(^DGPM("APRD",DFN,BEG))
. ; admission
. I X,X'>END S YY=1 Q
. ;Rx
. D OCL^PSOORRL(DFN,BEG,END) I $O(^TMP("PS",$J,0)) S YY=1 Q
S VSTH="",(IX,JX)=0
D VST^ORWCV(.VSTH,DFN,BEG,END)
F S IX=$O(VSTH(IX)) Q:'IX D
. F S JX=$O(LOC(JX)) Q:'JX D
. . I +$P($G(VSTH(IX)),";",3)=JX S YY=1 Q
I YY=1 G ACTQ
S IDT=BEG-.0001 F S IDT=$O(^SCE("ADFN",DFN,IDT)) Q:IDT<1!(IDT>END) D Q:YY ;IA #2065
. I '$D(LOC) S YY=1 Q
. S DA=0 F S DA=+$O(^SCE("ADFN",DFN,IDT,DA)) Q:DA<1 I $D(LOC(+$P($G(^SCE(DA,0)),U,4))) S YY=1 Q
ACTQ K ^UTILITY("VASD",$J),^TMP("PS",$J)
Q YY
;
BYPT(ORY,DFN,QRY) ; -- Returns report data in @ORY based on QRY parameters
Q:'$G(DFN) N PAT,ORYPAT,VA,VADM,VAIN,VAERR ;M ^XTMP("ORQRY",$G(DUZ)_";"_$H)=QRY
S ORY=$G(ORY,"^TMP($J)"),DFN=+DFN D OERR^VADPT
S ORYPAT("Patient.DFN")=DFN,PAT=DFN_";DPT("
S ORYPAT("Patient.Age")=VADM(4),ORYPAT("Patient.Name")=VADM(1)
S ORYPAT("Patient.Last4")=$E(VADM(1))_VA("BID")
S ORYPAT("Patient.Ward")=$S(VAIN(4):$P(VAIN(4),U,2)_" "_VAIN(5),1:"")
I $D(QRY("Document")) D DOCMTS
I $D(QRY("Order")) D ORDERS
I $D(QRY("Consult")) D CSLTS
I $D(QRY("Visit")) D VISITS
Q
;
DOCMTS ; -- Find documents
N DOCMT
M DOCMT=QRY("Document")
D DOCDT^ORQRY01(.DOCMT)
D QUERY^TIUQRY(ORY,.DOCMT,.ORYPAT)
I $D(DOCMT("NegativeSearch")) D NEGATE("Documents")
Q
;
CSLTS ; -- Find consults (treats consults as special case of orders)
N ORDER,ORGRP,SDATE,EDATE,ORCNT,X,CSLTMODE
M ORDER=QRY("Consult") S ORCNT=0,CSLTMODE=1
I '$D(ORDER("DisplayGroup")) D
. S ORDER("DisplayGroup",$O(^ORD(100.98,"B","CSLT",0)))=""
G ORDERS1
;
ORDERS ; -- Find orders
N ORDER,ORGRP,SDATE,EDATE,ORCNT,I
M ORDER=QRY("Order") S ORCNT=0
ORDERS1 N ORCBO I $D(ORDER("ItemCombo1"))>1 S (ORCBO(1),ORCBO(2))=-1
I $D(ORDER("DisplayGroup"))>1 S I=0 F S I=$O(ORDER("DisplayGroup",I)) Q:'I D GRP(I)
D DATES,@$S($D(ORDER("Abnormal")):"ARSX",1:"ACTX") ;$G(ORDER("View")):"AVWX"
; if looking for a combination and both not there, remove the orders
I $D(ORCBO),((ORCBO(1)=-1)!(ORCBO(2)=-1)) D
. D RMOV($S($G(CSLTMODE):"CST",1:"ORD"))
. S ORCNT=0
S:'$D(CSLTMODE) @ORY@(0,"Orders")=ORCNT
S:$D(CSLTMODE) @ORY@(0,"Consults")=ORCNT
I $D(ORDER("NegativeSearch")) D NEGATE($S($G(CSLTMODE):"Consults",1:"Orders"))
Q
;
GRP(DG) ; -- Setup display group DG in ORGRP()
N STK,MEM
S ORGRP(DG)="",STK=1,STK(STK)=DG_"^0",STK(0)=0,MEM=0
F S MEM=$O(^ORD(100.98,+STK(STK),1,MEM)) D @$S(+MEM'>0:"POP",1:"PROC") Q:STK<1
Q
POP S STK=STK-1,MEM=$P(STK(STK),"^",2)
Q
PROC S $P(STK(STK),"^",2)=MEM,DG=$P(^ORD(100.98,+STK(STK),1,MEM,0),"^",1)
S ORGRP(DG)="",STK=STK+1,STK(STK)=DG_"^0",MEM=0
Q
;
DATES ; -- Return SDATE and EDATE from TimeFrame
; [Inverted for rev-chron search]
N X S X=$O(ORDER("TimeFrame","")),SDATE=$P(X,":"),EDATE=$P(X,":",2)
I EDATE S EDATE=$S($L(EDATE,".")=2:EDATE+.0001,1:EDATE+1)
I SDATE S SDATE=$S($L(SDATE,".")=2:SDATE-.0001,1:SDATE)
S SDATE=9999999-$S(SDATE:SDATE,1:0),EDATE=9999999-$S(EDATE:EDATE,1:9999998)
S X=EDATE,EDATE=SDATE,SDATE=X
Q
;
AVWX ; -- use ORQ1 for order view
N X,DG,MULT,ORLIST,ORI,IFN,ACT
S X=$O(ORDER("TimeFrame","")),SDATE=$P(X,":"),EDATE=$P(X,":",2)
S DG=+$O(^ORD(100.98,"B","ALL",0)),X=$G(ORDER("View"))
S MULT=$S("^1^6^8^9^10^11^13^14^20^22^"[(U_X_U):1,1:0)
D EN^ORQ1(PAT,,X,,SDATE,EDATE,,MULT)
S ORI=0 F S ORI=$O(^TMP("ORR",$J,ORLIST,ORI)) Q:ORI'>0 S IFN=$G(^(ORI)),ACT=$P(IFN,";",2) D CONT
K ^TMP("ORR",$J,ORLIST)
Q
;
ARSX ; -- loop on ARS xref
N IDX,IFN
S IDX="^OR(100,""ARS"",PAT,SDATE)"
F S IDX=$Q(@IDX) Q:$P(IDX,"""",4)'=PAT Q:$P(IDX,",",4)>EDATE D
. S IFN=+$P(IDX,",",5) D CONT
Q
ACTX ; -- loop on "ACT" xref
N IDX,IFN,ACT
S IDX="^OR(100,""ACT"",PAT,SDATE)"
F S IDX=$Q(@IDX) Q:$P(IDX,"""",4)'=PAT Q:$P(IDX,",",4)>EDATE D
. S IFN=+$P(IDX,",",6),ACT=+$P(IDX,",",7)
. I $P($G(^OR(100,IFN,8,ACT,0)),U,2)="NW"!$D(ORDER("SignStatus")) D CONT
Q
CONT ; -- Proceed with checking order ORDER() & IFN [from ARS,ACT]
N X,X0,X3,X7,X8,ACTN
S X0=$G(^OR(100,IFN,0)),X3=$G(^(3)),X7=$G(^(7))
Q:$P(X3,U,8) I $P(X3,U,9),'$P($G(^OR(100,+$P(X3,U,9),3)),U,8) Q
;I $L($P(X0,U,17)),"^10^11^"[(U_STS_U) S X=$$LAPSED^OREVNTX($P(X0,U,17))
I $D(ORGRP) Q:'$D(ORGRP(+$P(X0,U,11)))
I $D(ORDER("Requestor")) Q:'$D(ORDER("Requestor",+$P(X0,U,4))) ;X8?
I $D(ORDER("Status")) Q:'$D(ORDER("Status",+$P(X3,U,3)))
I $D(ORDER("Abnormal")) Q:'$P(X7,U,2)
I $D(ORDER("Orderable")) Q:'$$OI(IFN)
S ACTN=$S($G(ACT):ACT,1:$$LAST(IFN)),X8=$G(^OR(100,IFN,8,ACTN,0))
S TXT=+$P(X8,U,14) I $D(ORDER("Text")) Q:'$$TEXT(IFN,TXT)
I $D(ORDER("SignStatus")) Q:'$L($P(X8,U,4)) Q:'$D(ORDER("SignStatus",+$P(X8,U,4)))
;I $D(ORDER("Requestor")) Q:'$D(ORDER("Requestor",+$P(X8,U,3)))
D SAVEORD
Q
;
LAST(IFN) ; -- Returns DA of current/latest action for order IFN
; (Only NW or XX actions?)
N Y S Y=+$P($G(^OR(100,IFN,3)),U,7)
I Y<1 S Y=+$O(^OR(100,IFN,8,"?"),-1)
Q Y
;
OI(IFN) ; -- Return 1 or 0, if IFN contains any requested OI's
N ITM,Y S Y=0
S ITM=0 F S ITM=$O(ORDER("Orderable",ITM)) Q:ITM<1 I $D(^OR(100,IFN,.1,"B",ITM)) S Y=1 Q
Q Y
;
TEXT(IFN,TXT) ; -- Return 1 or 0, if IFN;TXT text contains requested string
N X,Y,I S Y=0
S X="" F S X=$O(ORDER("Text",X)) Q:X="" S I=0 D
. F S I=+$O(^OR(100,IFN,8,TXT,.1,I)) Q:I<1 I $$UP^XLFSTR($G(^(I,0)))[$$UP^XLFSTR(X) S Y=1 Q
Q Y
;
SAVEORD ; -- Save order number in @ORY@("ORD:IFN;ACTN")
; Called from CONT: also uses X0,X3,X8,TXT,ORYPAT
N ID,X
S ID=$S($D(CSLTMODE):"CST:",1:"ORD:")_IFN_";"_ACTN,ORCNT=ORCNT+1
S @ORY@(ID,"Order.Datetime")=$S($P(X0,U,8):$P(X0,U,8),1:$P(X8,U,16))
S @ORY@(ID,"Order.DisplayGroup")=$P($G(^ORD(100.98,+$P(X0,U,11),0)),U)
S @ORY@(ID,"Order.Provider")=$P($G(^VA(200,+$P(X0,U,4),0)),U)
S X=$P(X8,U,4),@ORY@(ID,"Order.Signature")=$S(X=0!(X=4):"on chart",X=1:"electronically signed",X=2:"unsigned",X=3:"not required",X=5:"cancelled",X=6:"service correction",X=7:"digitally signed",1:"")
S @ORY@(ID,"Order.Status")=$$LOW^XLFSTR($P($G(^ORD(100.01,+$P(X3,U,3),0)),U))
S @ORY@(ID,"Order.Abnormal")=$S($P(X7,U,2):"YES",X7:"NO",1:"")
S @ORY@(ID,"Order.Finding")=$P(X7,U,3)
S @ORY@(ID,"Order.Text")=$$BLDTXT(IFN,TXT)
M @ORY@(ID)=ORYPAT
I $D(ORCBO) D SETCBO(IFN)
Q
BLDTXT(IFN,TXT) ; -- Return concatenated order text up to 245 chars
N I,ALL,PART,MAX S ALL="",MAX=0
S I=0 F S I=$O(^OR(100,IFN,8,TXT,.1,I)) Q:'I D Q:MAX
. S PART=$G(^OR(100,IFN,8,TXT,.1,I,0))
. I ($L(ALL)+$L(PART))<245 S ALL=ALL_$S($L(ALL):" ",1:"")_PART
. E S MAX=1
I MAX S ALL=ALL_"..."
Q ALL
;
SETCBO(IFN) ; -- Set flags when looking for combinations of orderable items
N I,OI
S I=0 F S I=$O(^OR(100,IFN,.1,I)) Q:'I D
. S OI=+^OR(100,IFN,.1,I,0)
. I $D(ORDER("ItemCombo1",OI)) S ORCBO(1)=1
. I $D(ORDER("ItemCombo2",OI)) S ORCBO(2)=1
Q
;
VISITS ; -- Find clinic visits
; Save in @ORY@("VST:TYPE;DT;LOC")
N VISIT,X,SDATE,EDATE,ORV,ORCNT,I,ID,VTYPE
M VISIT=QRY("Visit")
S X=$O(VISIT("TimeFrame","")),SDATE=$P(X,":"),EDATE=$P(X,":",2)
S SDATE=SDATE-.0001 S:$L(EDATE,".")<2 EDATE=EDATE+.9999
D VST^ORWCV(.ORV,DFN,SDATE,EDATE,1) S ORCNT=0
S I=0 F S I=+$O(ORV(I)) Q:I<1 D
. S X=ORV(I) Q:'$$ISVALID(X)
. Q:$P(X,";",2)>(EDATE+1)
. S VTYPE=$P(ORV(I),";")
. S ID="VST:"_$P(X,U),ORCNT=ORCNT+1
. S @ORY@(ID,"Visit.Datetime")=$P(ID,";",2)
. S @ORY@(ID,"Visit.Location")=$P(X,U,3)
. S @ORY@(ID,"Visit.NoShow")=$S($E(X)'="A":"",$$UP^XLFSTR($P(X,U,4))["NO-SHOW":"YES",1:"NO")
. S:VTYPE'="I" @ORY@(ID,"Visit.Status")=$P(X,U,4)
. M @ORY@(ID)=ORYPAT
S @ORY@(0,"Visits")=ORCNT
I $D(VISIT("NegativeSearch")) D NEGATE("Visits")
Q
;
ISVALID(VST) ; -- True: valid visit data
N IX,VSTID,ISVAL
S VSTID=+$P(VST,";",3)
S (IX,ISVAL)=0
F S IX=$O(VISIT("Location",IX)) Q:'IX D
. I IX=VSTID S ISVAL=1 Q
S:'$D(VISIT("Location")) ISVAL=1
Q ISVAL
;
NEGATE(SRCHITM) ; -- set report to return nodes only when nothing found
N ID,RTNCNT,PRE
I SRCHITM="Consults" S ID="PTC:"_DFN,PRE="CST"
I SRCHITM="Orders" S ID="PTO:"_DFN,PRE="ORD"
I SRCHITM="Documents" S ID="PTD:"_DFN,PRE="DOC"
I SRCHITM="Visits" S ID="PTV:"_DFN,PRE="VST"
S RTNCNT=@ORY@(0,SRCHITM)
I RTNCNT=0 D
. M @ORY@(ID)=ORYPAT
. S @ORY@(ID,"Patient.NoneFound")=SRCHITM
. S @ORY@(0,SRCHITM)=1
E D
. D RMOV(PRE)
. S @ORY@(0,SRCHITM)=0
Q
;
RMOV(PRE) ; -- Remove nodes based on ID prefix
N ID
S ID="" F S ID=$O(@ORY@(ID)) Q:ID="" I $P(ID,":")=PRE K @ORY@(ID)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORQRY 9300 printed Sep 23, 2025@20:10:12 Page 2
ORQRY ; SLC/MKB/JDL - Order Query utilities ;3/17/03 14:45
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**153,174**;Dec 17, 1997
+2 ;
+3 ;
PP(DFN,PROV) ; -- Returns 1 or 0, if PROV is prim prov for DFN
+1 NEW X,Y
IF '$GET(DFN)!'$GET(PROV)
QUIT ""
+2 SET X=$$OUTPTPR^SDUTL3(+DFN)
SET Y=$SELECT(+X=+PROV:1,1:0)
+3 QUIT Y
+4 ;
ACT(DFN,BEG,END,LOC) ; -- Returns 1 or 0, if recent activity for DFN
+1 ; BEG = beginning date [default = DT-1yr]
+2 ; END = ending date [default = DT]
+3 ; LOC(IEN) = list of clinic IENs from #44 [default = all]
+4 NEW X,YY,VASD,VAERR,IDT,DA
+5 NEW VSTH,IX,JX
+6 SET DFN=+$GET(DFN)
SET YY=0
IF '$GET(DFN)
QUIT ""
+7 ;default=last year
SET BEG=$GET(BEG,DT-10000)
SET END=$GET(END,DT)
+8 IF END<BEG
SET X=END
SET END=BEG
SET BEG=X
+9 ;check inpatient, Rx data
IF '$DATA(LOC)
Begin DoDot:1
+10 ;curr inpt
+11 IF $GET(^DPT(DFN,.105))
SET YY=1
QUIT
+12 SET X=+$ORDER(^DGPM("APRD",DFN,BEG))
+13 ; admission
+14 IF X
IF X'>END
SET YY=1
QUIT
+15 ;Rx
+16 DO OCL^PSOORRL(DFN,BEG,END)
IF $ORDER(^TMP("PS",$JOB,0))
SET YY=1
QUIT
End DoDot:1
if YY
GOTO ACTQ
+17 SET VSTH=""
SET (IX,JX)=0
+18 DO VST^ORWCV(.VSTH,DFN,BEG,END)
+19 FOR
SET IX=$ORDER(VSTH(IX))
if 'IX
QUIT
Begin DoDot:1
+20 FOR
SET JX=$ORDER(LOC(JX))
if 'JX
QUIT
Begin DoDot:2
+21 IF +$PIECE($GET(VSTH(IX)),";",3)=JX
SET YY=1
QUIT
End DoDot:2
End DoDot:1
+22 IF YY=1
GOTO ACTQ
+23 ;IA #2065
SET IDT=BEG-.0001
FOR
SET IDT=$ORDER(^SCE("ADFN",DFN,IDT))
if IDT<1!(IDT>END)
QUIT
Begin DoDot:1
+24 IF '$DATA(LOC)
SET YY=1
QUIT
+25 SET DA=0
FOR
SET DA=+$ORDER(^SCE("ADFN",DFN,IDT,DA))
if DA<1
QUIT
IF $DATA(LOC(+$PIECE($GET(^SCE(DA,0)),U,4)))
SET YY=1
QUIT
End DoDot:1
if YY
QUIT
ACTQ KILL ^UTILITY("VASD",$JOB),^TMP("PS",$JOB)
+1 QUIT YY
+2 ;
BYPT(ORY,DFN,QRY) ; -- Returns report data in @ORY based on QRY parameters
+1 ;M ^XTMP("ORQRY",$G(DUZ)_";"_$H)=QRY
if '$GET(DFN)
QUIT
NEW PAT,ORYPAT,VA,VADM,VAIN,VAERR
+2 SET ORY=$GET(ORY,"^TMP($J)")
SET DFN=+DFN
DO OERR^VADPT
+3 SET ORYPAT("Patient.DFN")=DFN
SET PAT=DFN_";DPT("
+4 SET ORYPAT("Patient.Age")=VADM(4)
SET ORYPAT("Patient.Name")=VADM(1)
+5 SET ORYPAT("Patient.Last4")=$EXTRACT(VADM(1))_VA("BID")
+6 SET ORYPAT("Patient.Ward")=$SELECT(VAIN(4):$PIECE(VAIN(4),U,2)_" "_VAIN(5),1:"")
+7 IF $DATA(QRY("Document"))
DO DOCMTS
+8 IF $DATA(QRY("Order"))
DO ORDERS
+9 IF $DATA(QRY("Consult"))
DO CSLTS
+10 IF $DATA(QRY("Visit"))
DO VISITS
+11 QUIT
+12 ;
DOCMTS ; -- Find documents
+1 NEW DOCMT
+2 MERGE DOCMT=QRY("Document")
+3 DO DOCDT^ORQRY01(.DOCMT)
+4 DO QUERY^TIUQRY(ORY,.DOCMT,.ORYPAT)
+5 IF $DATA(DOCMT("NegativeSearch"))
DO NEGATE("Documents")
+6 QUIT
+7 ;
CSLTS ; -- Find consults (treats consults as special case of orders)
+1 NEW ORDER,ORGRP,SDATE,EDATE,ORCNT,X,CSLTMODE
+2 MERGE ORDER=QRY("Consult")
SET ORCNT=0
SET CSLTMODE=1
+3 IF '$DATA(ORDER("DisplayGroup"))
Begin DoDot:1
+4 SET ORDER("DisplayGroup",$ORDER(^ORD(100.98,"B","CSLT",0)))=""
End DoDot:1
+5 GOTO ORDERS1
+6 ;
ORDERS ; -- Find orders
+1 NEW ORDER,ORGRP,SDATE,EDATE,ORCNT,I
+2 MERGE ORDER=QRY("Order")
SET ORCNT=0
ORDERS1 NEW ORCBO
IF $DATA(ORDER("ItemCombo1"))>1
SET (ORCBO(1),ORCBO(2))=-1
+1 IF $DATA(ORDER("DisplayGroup"))>1
SET I=0
FOR
SET I=$ORDER(ORDER("DisplayGroup",I))
if 'I
QUIT
DO GRP(I)
+2 ;$G(ORDER("View")):"AVWX"
DO DATES
DO @$SELECT($DATA(ORDER("Abnormal")):"ARSX",1:"ACTX")
+3 ; if looking for a combination and both not there, remove the orders
+4 IF $DATA(ORCBO)
IF ((ORCBO(1)=-1)!(ORCBO(2)=-1))
Begin DoDot:1
+5 DO RMOV($SELECT($GET(CSLTMODE):"CST",1:"ORD"))
+6 SET ORCNT=0
End DoDot:1
+7 if '$DATA(CSLTMODE)
SET @ORY@(0,"Orders")=ORCNT
+8 if $DATA(CSLTMODE)
SET @ORY@(0,"Consults")=ORCNT
+9 IF $DATA(ORDER("NegativeSearch"))
DO NEGATE($SELECT($GET(CSLTMODE):"Consults",1:"Orders"))
+10 QUIT
+11 ;
GRP(DG) ; -- Setup display group DG in ORGRP()
+1 NEW STK,MEM
+2 SET ORGRP(DG)=""
SET STK=1
SET STK(STK)=DG_"^0"
SET STK(0)=0
SET MEM=0
+3 FOR
SET MEM=$ORDER(^ORD(100.98,+STK(STK),1,MEM))
DO @$SELECT(+MEM'>0:"POP",1:"PROC")
if STK<1
QUIT
+4 QUIT
POP SET STK=STK-1
SET MEM=$PIECE(STK(STK),"^",2)
+1 QUIT
PROC SET $PIECE(STK(STK),"^",2)=MEM
SET DG=$PIECE(^ORD(100.98,+STK(STK),1,MEM,0),"^",1)
+1 SET ORGRP(DG)=""
SET STK=STK+1
SET STK(STK)=DG_"^0"
SET MEM=0
+2 QUIT
+3 ;
DATES ; -- Return SDATE and EDATE from TimeFrame
+1 ; [Inverted for rev-chron search]
+2 NEW X
SET X=$ORDER(ORDER("TimeFrame",""))
SET SDATE=$PIECE(X,":")
SET EDATE=$PIECE(X,":",2)
+3 IF EDATE
SET EDATE=$SELECT($LENGTH(EDATE,".")=2:EDATE+.0001,1:EDATE+1)
+4 IF SDATE
SET SDATE=$SELECT($LENGTH(SDATE,".")=2:SDATE-.0001,1:SDATE)
+5 SET SDATE=9999999-$SELECT(SDATE:SDATE,1:0)
SET EDATE=9999999-$SELECT(EDATE:EDATE,1:9999998)
+6 SET X=EDATE
SET EDATE=SDATE
SET SDATE=X
+7 QUIT
+8 ;
AVWX ; -- use ORQ1 for order view
+1 NEW X,DG,MULT,ORLIST,ORI,IFN,ACT
+2 SET X=$ORDER(ORDER("TimeFrame",""))
SET SDATE=$PIECE(X,":")
SET EDATE=$PIECE(X,":",2)
+3 SET DG=+$ORDER(^ORD(100.98,"B","ALL",0))
SET X=$GET(ORDER("View"))
+4 SET MULT=$SELECT("^1^6^8^9^10^11^13^14^20^22^"[(U_X_U):1,1:0)
+5 DO EN^ORQ1(PAT,,X,,SDATE,EDATE,,MULT)
+6 SET ORI=0
FOR
SET ORI=$ORDER(^TMP("ORR",$JOB,ORLIST,ORI))
if ORI'>0
QUIT
SET IFN=$GET(^(ORI))
SET ACT=$PIECE(IFN,";",2)
DO CONT
+7 KILL ^TMP("ORR",$JOB,ORLIST)
+8 QUIT
+9 ;
ARSX ; -- loop on ARS xref
+1 NEW IDX,IFN
+2 SET IDX="^OR(100,""ARS"",PAT,SDATE)"
+3 FOR
SET IDX=$QUERY(@IDX)
if $PIECE(IDX,"""",4)'=PAT
QUIT
if $PIECE(IDX,",",4)>EDATE
QUIT
Begin DoDot:1
+4 SET IFN=+$PIECE(IDX,",",5)
DO CONT
End DoDot:1
+5 QUIT
ACTX ; -- loop on "ACT" xref
+1 NEW IDX,IFN,ACT
+2 SET IDX="^OR(100,""ACT"",PAT,SDATE)"
+3 FOR
SET IDX=$QUERY(@IDX)
if $PIECE(IDX,"""",4)'=PAT
QUIT
if $PIECE(IDX,",",4)>EDATE
QUIT
Begin DoDot:1
+4 SET IFN=+$PIECE(IDX,",",6)
SET ACT=+$PIECE(IDX,",",7)
+5 IF $PIECE($GET(^OR(100,IFN,8,ACT,0)),U,2)="NW"!$DATA(ORDER("SignStatus"))
DO CONT
End DoDot:1
+6 QUIT
CONT ; -- Proceed with checking order ORDER() & IFN [from ARS,ACT]
+1 NEW X,X0,X3,X7,X8,ACTN
+2 SET X0=$GET(^OR(100,IFN,0))
SET X3=$GET(^(3))
SET X7=$GET(^(7))
+3 if $PIECE(X3,U,8)
QUIT
IF $PIECE(X3,U,9)
IF '$PIECE($GET(^OR(100,+$PIECE(X3,U,9),3)),U,8)
QUIT
+4 ;I $L($P(X0,U,17)),"^10^11^"[(U_STS_U) S X=$$LAPSED^OREVNTX($P(X0,U,17))
+5 IF $DATA(ORGRP)
if '$DATA(ORGRP(+$PIECE(X0,U,11)))
QUIT
+6 ;X8?
IF $DATA(ORDER("Requestor"))
if '$DATA(ORDER("Requestor",+$PIECE(X0,U,4)))
QUIT
+7 IF $DATA(ORDER("Status"))
if '$DATA(ORDER("Status",+$PIECE(X3,U,3)))
QUIT
+8 IF $DATA(ORDER("Abnormal"))
if '$PIECE(X7,U,2)
QUIT
+9 IF $DATA(ORDER("Orderable"))
if '$$OI(IFN)
QUIT
+10 SET ACTN=$SELECT($GET(ACT):ACT,1:$$LAST(IFN))
SET X8=$GET(^OR(100,IFN,8,ACTN,0))
+11 SET TXT=+$PIECE(X8,U,14)
IF $DATA(ORDER("Text"))
if '$$TEXT(IFN,TXT)
QUIT
+12 IF $DATA(ORDER("SignStatus"))
if '$LENGTH($PIECE(X8,U,4))
QUIT
if '$DATA(ORDER("SignStatus",+$PIECE(X8,U,4)))
QUIT
+13 ;I $D(ORDER("Requestor")) Q:'$D(ORDER("Requestor",+$P(X8,U,3)))
+14 DO SAVEORD
+15 QUIT
+16 ;
LAST(IFN) ; -- Returns DA of current/latest action for order IFN
+1 ; (Only NW or XX actions?)
+2 NEW Y
SET Y=+$PIECE($GET(^OR(100,IFN,3)),U,7)
+3 IF Y<1
SET Y=+$ORDER(^OR(100,IFN,8,"?"),-1)
+4 QUIT Y
+5 ;
OI(IFN) ; -- Return 1 or 0, if IFN contains any requested OI's
+1 NEW ITM,Y
SET Y=0
+2 SET ITM=0
FOR
SET ITM=$ORDER(ORDER("Orderable",ITM))
if ITM<1
QUIT
IF $DATA(^OR(100,IFN,.1,"B",ITM))
SET Y=1
QUIT
+3 QUIT Y
+4 ;
TEXT(IFN,TXT) ; -- Return 1 or 0, if IFN;TXT text contains requested string
+1 NEW X,Y,I
SET Y=0
+2 SET X=""
FOR
SET X=$ORDER(ORDER("Text",X))
if X=""
QUIT
SET I=0
Begin DoDot:1
+3 FOR
SET I=+$ORDER(^OR(100,IFN,8,TXT,.1,I))
if I<1
QUIT
IF $$UP^XLFSTR($GET(^(I,0)))[$$UP^XLFSTR(X)
SET Y=1
QUIT
End DoDot:1
+4 QUIT Y
+5 ;
SAVEORD ; -- Save order number in @ORY@("ORD:IFN;ACTN")
+1 ; Called from CONT: also uses X0,X3,X8,TXT,ORYPAT
+2 NEW ID,X
+3 SET ID=$SELECT($DATA(CSLTMODE):"CST:",1:"ORD:")_IFN_";"_ACTN
SET ORCNT=ORCNT+1
+4 SET @ORY@(ID,"Order.Datetime")=$SELECT($PIECE(X0,U,8):$PIECE(X0,U,8),1:$PIECE(X8,U,16))
+5 SET @ORY@(ID,"Order.DisplayGroup")=$PIECE($GET(^ORD(100.98,+$PIECE(X0,U,11),0)),U)
+6 SET @ORY@(ID,"Order.Provider")=$PIECE($GET(^VA(200,+$PIECE(X0,U,4),0)),U)
+7 SET X=$PIECE(X8,U,4)
SET @ORY@(ID,"Order.Signature")=$SELECT(X=0!(X=4):"on chart",X=1:"electronically signed",X=2:"unsigned",X=3:"not required",X=5:"cancelled",X=6:"service correction",X=7:"digitally signed",1:"")
+8 SET @ORY@(ID,"Order.Status")=$$LOW^XLFSTR($PIECE($GET(^ORD(100.01,+$PIECE(X3,U,3),0)),U))
+9 SET @ORY@(ID,"Order.Abnormal")=$SELECT($PIECE(X7,U,2):"YES",X7:"NO",1:"")
+10 SET @ORY@(ID,"Order.Finding")=$PIECE(X7,U,3)
+11 SET @ORY@(ID,"Order.Text")=$$BLDTXT(IFN,TXT)
+12 MERGE @ORY@(ID)=ORYPAT
+13 IF $DATA(ORCBO)
DO SETCBO(IFN)
+14 QUIT
BLDTXT(IFN,TXT) ; -- Return concatenated order text up to 245 chars
+1 NEW I,ALL,PART,MAX
SET ALL=""
SET MAX=0
+2 SET I=0
FOR
SET I=$ORDER(^OR(100,IFN,8,TXT,.1,I))
if 'I
QUIT
Begin DoDot:1
+3 SET PART=$GET(^OR(100,IFN,8,TXT,.1,I,0))
+4 IF ($LENGTH(ALL)+$LENGTH(PART))<245
SET ALL=ALL_$SELECT($LENGTH(ALL):" ",1:"")_PART
+5 IF '$TEST
SET MAX=1
End DoDot:1
if MAX
QUIT
+6 IF MAX
SET ALL=ALL_"..."
+7 QUIT ALL
+8 ;
SETCBO(IFN) ; -- Set flags when looking for combinations of orderable items
+1 NEW I,OI
+2 SET I=0
FOR
SET I=$ORDER(^OR(100,IFN,.1,I))
if 'I
QUIT
Begin DoDot:1
+3 SET OI=+^OR(100,IFN,.1,I,0)
+4 IF $DATA(ORDER("ItemCombo1",OI))
SET ORCBO(1)=1
+5 IF $DATA(ORDER("ItemCombo2",OI))
SET ORCBO(2)=1
End DoDot:1
+6 QUIT
+7 ;
VISITS ; -- Find clinic visits
+1 ; Save in @ORY@("VST:TYPE;DT;LOC")
+2 NEW VISIT,X,SDATE,EDATE,ORV,ORCNT,I,ID,VTYPE
+3 MERGE VISIT=QRY("Visit")
+4 SET X=$ORDER(VISIT("TimeFrame",""))
SET SDATE=$PIECE(X,":")
SET EDATE=$PIECE(X,":",2)
+5 SET SDATE=SDATE-.0001
if $LENGTH(EDATE,".")<2
SET EDATE=EDATE+.9999
+6 DO VST^ORWCV(.ORV,DFN,SDATE,EDATE,1)
SET ORCNT=0
+7 SET I=0
FOR
SET I=+$ORDER(ORV(I))
if I<1
QUIT
Begin DoDot:1
+8 SET X=ORV(I)
if '$$ISVALID(X)
QUIT
+9 if $PIECE(X,";",2)>(EDATE+1)
QUIT
+10 SET VTYPE=$PIECE(ORV(I),";")
+11 SET ID="VST:"_$PIECE(X,U)
SET ORCNT=ORCNT+1
+12 SET @ORY@(ID,"Visit.Datetime")=$PIECE(ID,";",2)
+13 SET @ORY@(ID,"Visit.Location")=$PIECE(X,U,3)
+14 SET @ORY@(ID,"Visit.NoShow")=$SELECT($EXTRACT(X)'="A":"",$$UP^XLFSTR($PIECE(X,U,4))["NO-SHOW":"YES",1:"NO")
+15 if VTYPE'="I"
SET @ORY@(ID,"Visit.Status")=$PIECE(X,U,4)
+16 MERGE @ORY@(ID)=ORYPAT
End DoDot:1
+17 SET @ORY@(0,"Visits")=ORCNT
+18 IF $DATA(VISIT("NegativeSearch"))
DO NEGATE("Visits")
+19 QUIT
+20 ;
ISVALID(VST) ; -- True: valid visit data
+1 NEW IX,VSTID,ISVAL
+2 SET VSTID=+$PIECE(VST,";",3)
+3 SET (IX,ISVAL)=0
+4 FOR
SET IX=$ORDER(VISIT("Location",IX))
if 'IX
QUIT
Begin DoDot:1
+5 IF IX=VSTID
SET ISVAL=1
QUIT
End DoDot:1
+6 if '$DATA(VISIT("Location"))
SET ISVAL=1
+7 QUIT ISVAL
+8 ;
NEGATE(SRCHITM) ; -- set report to return nodes only when nothing found
+1 NEW ID,RTNCNT,PRE
+2 IF SRCHITM="Consults"
SET ID="PTC:"_DFN
SET PRE="CST"
+3 IF SRCHITM="Orders"
SET ID="PTO:"_DFN
SET PRE="ORD"
+4 IF SRCHITM="Documents"
SET ID="PTD:"_DFN
SET PRE="DOC"
+5 IF SRCHITM="Visits"
SET ID="PTV:"_DFN
SET PRE="VST"
+6 SET RTNCNT=@ORY@(0,SRCHITM)
+7 IF RTNCNT=0
Begin DoDot:1
+8 MERGE @ORY@(ID)=ORYPAT
+9 SET @ORY@(ID,"Patient.NoneFound")=SRCHITM
+10 SET @ORY@(0,SRCHITM)=1
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 DO RMOV(PRE)
+13 SET @ORY@(0,SRCHITM)=0
End DoDot:1
+14 QUIT
+15 ;
RMOV(PRE) ; -- Remove nodes based on ID prefix
+1 NEW ID
+2 SET ID=""
FOR
SET ID=$ORDER(@ORY@(ID))
if ID=""
QUIT
IF $PIECE(ID,":")=PRE
KILL @ORY@(ID)
+3 QUIT
