ORWDXA1 ;SLC/JMC - Utilities for Order Flag Actions ;Dec 14, 2021@08:39:22
;;3.0;ORDER ENTRY/RESULTS REPORTING;**539,405**;Dec 17, 1997;Build 211
;Per VA Directive 6402, this routine should not be modified.
;
FLAGACT(LST,ORIFN,ACTION) ;perform action on flag order
N DA,ORNOW,CNT,X,RES,ORFIENS,ORFDA,FDAIEN,ERR,REC,ORVP,X3,USR
S DA=$P(ORIFN,";",2)
S ACTION=$G(ACTION,"ALL")
; get recipients
I ACTION="RECIPIENTS"!(ACTION="ALL") D I ACTION'="ALL" Q
. D FLAGRCPT(.LST,ORIFN)
M RES=LST
K LST
; get comments
I ACTION="COMMENTS"!(ACTION="ALL") D I ACTION'="ALL" Q
. D FLGCOM(.LST,ORIFN)
I $D(RES) S CNT=$O(RES("A"),-1),X=0 F S X=$O(LST(X)) Q:'X S CNT=CNT+1,RES(CNT)=LST(X)
M LST=RES
Q
FLAGRCPT(LST,ORIFN) ; flag recipients
N DA,CNT,X,USR,Y
S DA=$P(ORIFN,";",2),(CNT,X)=0
F S X=$O(^OR(100,+ORIFN,8,DA,6,X)) Q:'X S CNT=CNT+1,Y=$G(^(X,0)),USR=+Y,LST(CNT)=USR_U_$$USER^ORQ20(USR)_" added on "_$$DATE^ORQ20($P(Y,U,2))
Q
FLAGCOM(LST,ORIFN,ORCOM,ORALRP) ; flag comments, add
N ORDA,ORVP,ORNOW,ORFIENS,ORFDA,ORAUSR,ORFERR,ORFNM,USR,X,X3
S ORDA=$P(ORIFN,";",2),ORVP=+$P(^OR(100,+ORIFN,0),U,2)
I $O(ORCOM(""))="" S LST(1)="0^Comments required, no action taken." Q
I '$D(^OR(100,+ORIFN)) S LST(1)="0^No such order, no action taken." Q
S ORNOW=$$NOW^XLFDT
S ORFIENS="?+1"_","_ORDA_","_+ORIFN_","
S ORFDA(100.843,ORFIENS,.01)=ORNOW
S ORFDA(100.843,ORFIENS,1)=DUZ
D UPDATE^DIE("","ORFDA","ORFNM","ORFERR")
I ($G(ORFERR)'="")!('+$G(ORFNM(1))) S LST(1)="0^Error while adding Comment data." K ORFERR Q
;file comments
K ^TMP($J,"WP")
D WP^DIE(100.843,ORFNM(1)_","_ORDA_","_$P(ORIFN,";")_",",2,,"ORCOM","ORFERR")
I $G(ORFERR)'="" S LST(1)="0^Error adding comments." K ORFERR Q
K ORFIENS,ORFDA
;get recipients on file
S X=0
F S X=$O(^OR(100,+ORIFN,8,ORDA,6,X)) Q:'X S USR=$P($G(^(X,0)),"^") I USR S ORAUSR(USR)=""
;File additional alert Recipients
S X=0,ORFIENS="?+1"_","_ORDA_","_+ORIFN_","
F S X=$O(ORALRP(X)) Q:'X S USR=+ORALRP(X) I USR,'$D(ORAUSR(USR)) D I $G(ORFERR)'="" Q
. S ORFDA(100.842,ORFIENS,.01)=USR
. S ORFDA(100.842,ORFIENS,1)=ORNOW
. S ORFDA(100.842,ORFIENS,2)=DUZ
. D UPDATE^DIE("","ORFDA","","ORFERR")
. I $G(ORFERR)'="" S LST(1)="0^Error adding alert recipient "_USR Q
. S ORAUSR(USR)=""
S LST(1)="1^Comments successfully added."
; send notification to originator and recipients
S X3=$G(^OR(100,+ORIFN,8,ORDA,3)) I $P(X3,U,4)'="" S ORAUSR(+$P(X3,U,4))=""
K ORFDA,ORAUSR(DUZ) ;don't sent alert to user adding comment
D CMTMSG(ORIFN,ORVP,.ORAUSR)
Q
;
CMTMSG(ORIFN,ORVP,ORAUSR) ; send alert notification information to recipients
N ORCMSG,ORN,ORDFN,OR3,ORYT
S ORCMSG="Comment Added to Flagged Order: "
S ORN=8,ORDFN=+ORVP,OR3=$G(^OR(100,+ORIFN,3))
D TEXT^ORQ12(.ORYT,+ORIFN_";"_+$P(OR3,U,7),20)
S ORCMSG=ORCMSG_$G(ORYT(1))
D EN^ORB3(ORN,ORDFN,+ORIFN,.ORAUSR,ORCMSG)
Q
FLGCOM(LST,ORIFN) ; flag comments, get
N DA,CNT,X,Y,ORZ,DIWL,DIWR,DIWF,DATA,I
S DA=$P(ORIFN,";",2),(CNT,Y)=0
D:$D(^OR(100,+ORIFN,8,DA,3))
. Q:$G(ACTION)=""
. N BFLAG S BFLAG=$G(^OR(100,+ORIFN,8,DA,3))
. S CNT=CNT+1,LST(CNT)="<COMMENT>"
. S CNT=CNT+1,LST(CNT)=$P(BFLAG,U,3)_";"_$$DATE^ORQ20($P(BFLAG,U,3))_U_$P(BFLAG,U,4)_";"_$$USER^ORQ20($P(BFLAG,U,4))
. S CNT=CNT+1,LST(CNT)="Flagged Reason: "_$P(BFLAG,U,5)
. S CNT=CNT+1,LST(CNT)="</COMMENT>"
S DIWL=1,DIWR=70,DIWF="C70" K ^UTILITY($J,"W")
F S Y=$O(^OR(100,+ORIFN,8,DA,9,Y)) Q:'Y D
. S DATA=$G(^OR(100,+ORIFN,8,DA,9,Y,0))
. S CNT=CNT+1,LST(CNT)="<COMMENT>"
. S CNT=CNT+1,LST(CNT)=$P(DATA,U)_";"_$$DATE^ORQ20($P(DATA,U))_U_$P(DATA,U,2)_";"_$$USER^ORQ20($P(DATA,U,2))
. S ORZ=0 F S ORZ=$O(^OR(100,+ORIFN,8,DA,9,Y,"COM",ORZ)) Q:'ORZ S X=^(ORZ,0) D ^DIWP
. S I=0 F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:'I S CNT=CNT+1,LST(CNT)=^(I,0)
. S CNT=CNT+1,LST(CNT)="</COMMENT>"
. K ^UTILITY($J,"W")
Q
FLGHST(ORY,ORIFN) ;archive history of flag order
N X3,F,Y
N ORI,X3,CNT,ORJ
S ORI=$P(ORIFN,";",2),CNT=0
I $D(^OR(100,+ORIFN,8,ORI,3)) D ;Un-/Flagged
. S X3=$G(^OR(100,+ORIFN,8,ORI,3))
. S CNT=CNT+1,ORY(CNT)="Flagged by: "_$$USER^ORQ20(+$P(X3,U,4))_" on "_$$DATE^ORQ20($P(X3,U,3))
. S CNT=CNT+1,ORY(CNT)=" "_$P(X3,U,5)
. I $P(X3,U,10)'="" S CNT=CNT+1,ORY(CNT)="No Action Alert: "_$$DATE^ORQ20($P(X3,U,10))
;flagged recipients
S ORJ=0,F=0 F S ORJ=$O(^OR(100,+ORIFN,8,ORI,6,ORJ)) Q:'ORJ S Y=^(ORJ,0) D
. S CNT=CNT+1,ORY(CNT)=$S('F:"Recipients: ",1:" ")_$$USER^ORQ20(+Y)_" added on "_$$DATE^ORQ20($P(Y,U,2))_" by "_$$USER^ORQ20(+$P(Y,U,3)),F=1
;flagged comments
N DIWL,DIWR,DIWF,X,I,ORK
S ORJ=0,F=0 F S ORJ=$O(^OR(100,+ORIFN,8,ORI,9,ORJ)) Q:'ORJ S Y=^(ORJ,0) D
. S CNT=CNT+1,ORY(CNT)=$S('F:"Comments by: ",1:" ")_$$USER^ORQ20($P(Y,U,2))_"on "_$$DATE^ORQ20(+Y),F=1
. S DIWL=19,DIWR=110,DIWF="I19" K ^UTILITY($J,"W")
. S ORK=0 F S ORK=$O(^OR(100,+ORIFN,8,ORI,9,ORJ,"COM",ORK)) Q:'ORK S X=^(ORK,0) D ^DIWP
. S I=0 F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:'I S CNT=CNT+1,ORY(CNT)=^(I,0)
K ^UTILITY($J,"W")
I $P($G(X3),U)=0 D
. S CNT=CNT+1,ORY(CNT)="Unflagged by: "_$$USER^ORQ20(+$P(X3,U,7))_" on "_$$DATE^ORQ20($P(X3,U,6))
. S CNT=CNT+1,ORY(CNT)=" "_$P(X3,U,8)
K ^UTILITY($J,"W")
Q
GETHST(ORFH,ORIFN) ;Get flag order history
N ORI,ORJ,ORK,CNT,Y
S ORI=$P(ORIFN,";",2),CNT=0
I $D(^OR(100,+ORIFN,8,ORI,"FHIS")) D
. S ORJ=0 F S ORJ=$O(^OR(100,+ORIFN,8,ORI,"FHIS",ORJ)) Q:'ORJ S ORK=0 D
. . S ORK=0 F S ORK=$O(^OR(100,+ORIFN,8,ORI,"FHIS",ORJ,"COM",ORK)) Q:'ORK S Y=^(ORK,0),CNT=CNT+1,ORFH(CNT)=Y
Q
SCHALRT(ORVP,ORIFN,OREXP) ;schedule alert in file #100.97
N ORDATA,ORDA3,ORACT,ORYT,ORNAM
I (ORVP="")!(ORIFN="")!(OREXP)="" Q
S ORACT=$P(ORIFN,";",2)
S ORDA3=$G(^OR(100,+ORIFN,8,ORACT,3))
S ORDATA("PATIENT")=ORVP
S ORDATA("WHEN")=OREXP
S ORDATA("WHO")=$P(ORDA3,U,4)
S ORDATA("ALERT")="98;ORD(100.9,"
S ORNAM=$$OI^ORX8(ORIFN)
S ORDATA("TITLE")="Order flag expired for "_$P(ORNAM,"^",2)_" on "_$$DATE^ORQ20(OREXP)
S ORDATA("IFN")=ORIFN
D SCHALRT^ORB3UTL(.ORDATA)
Q
;
FLAGTXTS(CLST,IFNS) ; get flag reason for list of orders
N L,DA,IFN,CNT
S (CNT,L)=0
F S L=$O(IFNS(L)) Q:'L S IFN=IFNS(L) D
. S DA=$S($P(IFN,";",2):$P(IFN,";",2),1:1),IFN=+IFN
. D FLRSON
Q
;
FLRSON ; flag reason
N FLAG,I,F,ORUSR,ORCOM,Z
S FLAG=$G(^OR(100,IFN,8,DA,3))
S CNT=CNT+1
S CLST(CNT)="~"_IFN_U_"FLAGGED: "_$$FMTE^XLFDT($P(FLAG,U,3))_" by "_$P($G(^VA(200,+$P(FLAG,U,4),0)),U)
S CNT=CNT+1
S CLST(CNT)=$P(FLAG,U,5) ; reason
I $P(FLAG,U,10)'="" S CNT=CNT+1,CLST(CNT)="NO ACTION ALERT: "_$$FMTE^XLFDT($P(FLAG,U,10))
D FLAGRCPT^ORWDXA1(.ORUSR,IFNS(L)) ; recipients
S (I,F)=0
F S I=$O(ORUSR(I)) Q:'I I ORUSR(I) D
. S CNT=CNT+1,CLST(CNT)=$S('F:"RECIPIENTS:"_$C(9),1:$C(9)_$C(9))_$P(ORUSR(I),U,2),F=1
D FLGCOM^ORWDXA1(.ORCOM,IFNS(L)) ; comments
S (I,F)=0
F S I=$O(ORCOM(I)) Q:'I I ORCOM(I)="<COMMENT>" S I=$O(ORCOM(I)) D
. S CNT=CNT+1,CLST(CNT)=$S('F:"COMMENTS:"_$C(9),1:$C(9)_$C(9))_$P($P(ORCOM(I),U,2),";",2)_" on "_$P($P(ORCOM(I),U),";",2),F=1
. F S I=$O(ORCOM(I)) Q:ORCOM(I)="</COMMENT>" D
. . S CNT=CNT+1,CLST(CNT)=$C(9)_ORCOM(I)
Q
;
MAP(Y) ; display group mapping
N C,I,X
D GRP(.X)
S C=0,I=0
F S I=$O(X(I)) Q:I="" S C=C+1,Y(I)=X(I)
Q
GRP(BYGRP) ;
N I,ORY,TOPINFO
D GETLST^XPAR(.ORY,"ALL","ORWOR CATEGORY SEQUENCE")
S I=0 F S I=$O(ORY(I)) Q:I="" D
. S BYGRP($P(ORY(I),U,2))=$P(ORY(I),U,2)
S I=0 F S I=$O(BYGRP(I)) Q:I="" S TOPINFO=BYGRP(I) D EXPAND(I)
Q
EXPAND(GROUP) ;
N I,CHILD
S I=0 F S I=$O(^ORD(100.98,GROUP,1,I)) Q:I<1 D
. S CHILD=$P(^ORD(100.98,GROUP,1,I,0),"^",1)
. I '$D(BYGRP(CHILD)) S BYGRP(CHILD)=TOPINFO D EXPAND(CHILD)
Q
;
CHOREXP(IFN) ;
Q:'$D(^OR(100.97,"E",IFN))
N DA,TD S DA=$O(^OR(100.97,"E",IFN,"")) Q:'DA
S TD=$P($G(^OR(100.97,DA,0)),U,3) Q:'TD!($$NOW^XLFDT()>TD)
S DIK="^OR(100.97," D ^DIK K DIK
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWDXA1 7972 printed Dec 13, 2024@02:35:55 Page 2
ORWDXA1 ;SLC/JMC - Utilities for Order Flag Actions ;Dec 14, 2021@08:39:22
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**539,405**;Dec 17, 1997;Build 211
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
FLAGACT(LST,ORIFN,ACTION) ;perform action on flag order
+1 NEW DA,ORNOW,CNT,X,RES,ORFIENS,ORFDA,FDAIEN,ERR,REC,ORVP,X3,USR
+2 SET DA=$PIECE(ORIFN,";",2)
+3 SET ACTION=$GET(ACTION,"ALL")
+4 ; get recipients
+5 IF ACTION="RECIPIENTS"!(ACTION="ALL")
Begin DoDot:1
+6 DO FLAGRCPT(.LST,ORIFN)
End DoDot:1
IF ACTION'="ALL"
QUIT
+7 MERGE RES=LST
+8 KILL LST
+9 ; get comments
+10 IF ACTION="COMMENTS"!(ACTION="ALL")
Begin DoDot:1
+11 DO FLGCOM(.LST,ORIFN)
End DoDot:1
IF ACTION'="ALL"
QUIT
+12 IF $DATA(RES)
SET CNT=$ORDER(RES("A"),-1)
SET X=0
FOR
SET X=$ORDER(LST(X))
if 'X
QUIT
SET CNT=CNT+1
SET RES(CNT)=LST(X)
+13 MERGE LST=RES
+14 QUIT
FLAGRCPT(LST,ORIFN) ; flag recipients
+1 NEW DA,CNT,X,USR,Y
+2 SET DA=$PIECE(ORIFN,";",2)
SET (CNT,X)=0
+3 FOR
SET X=$ORDER(^OR(100,+ORIFN,8,DA,6,X))
if 'X
QUIT
SET CNT=CNT+1
SET Y=$GET(^(X,0))
SET USR=+Y
SET LST(CNT)=USR_U_$$USER^ORQ20(USR)_" added on "_$$DATE^ORQ20($PIECE(Y,U,2))
+4 QUIT
FLAGCOM(LST,ORIFN,ORCOM,ORALRP) ; flag comments, add
+1 NEW ORDA,ORVP,ORNOW,ORFIENS,ORFDA,ORAUSR,ORFERR,ORFNM,USR,X,X3
+2 SET ORDA=$PIECE(ORIFN,";",2)
SET ORVP=+$PIECE(^OR(100,+ORIFN,0),U,2)
+3 IF $ORDER(ORCOM(""))=""
SET LST(1)="0^Comments required, no action taken."
QUIT
+4 IF '$DATA(^OR(100,+ORIFN))
SET LST(1)="0^No such order, no action taken."
QUIT
+5 SET ORNOW=$$NOW^XLFDT
+6 SET ORFIENS="?+1"_","_ORDA_","_+ORIFN_","
+7 SET ORFDA(100.843,ORFIENS,.01)=ORNOW
+8 SET ORFDA(100.843,ORFIENS,1)=DUZ
+9 DO UPDATE^DIE("","ORFDA","ORFNM","ORFERR")
+10 IF ($GET(ORFERR)'="")!('+$GET(ORFNM(1)))
SET LST(1)="0^Error while adding Comment data."
KILL ORFERR
QUIT
+11 ;file comments
+12 KILL ^TMP($JOB,"WP")
+13 DO WP^DIE(100.843,ORFNM(1)_","_ORDA_","_$PIECE(ORIFN,";")_",",2,,"ORCOM","ORFERR")
+14 IF $GET(ORFERR)'=""
SET LST(1)="0^Error adding comments."
KILL ORFERR
QUIT
+15 KILL ORFIENS,ORFDA
+16 ;get recipients on file
+17 SET X=0
+18 FOR
SET X=$ORDER(^OR(100,+ORIFN,8,ORDA,6,X))
if 'X
QUIT
SET USR=$PIECE($GET(^(X,0)),"^")
IF USR
SET ORAUSR(USR)=""
+19 ;File additional alert Recipients
+20 SET X=0
SET ORFIENS="?+1"_","_ORDA_","_+ORIFN_","
+21 FOR
SET X=$ORDER(ORALRP(X))
if 'X
QUIT
SET USR=+ORALRP(X)
IF USR
IF '$DATA(ORAUSR(USR))
Begin DoDot:1
+22 SET ORFDA(100.842,ORFIENS,.01)=USR
+23 SET ORFDA(100.842,ORFIENS,1)=ORNOW
+24 SET ORFDA(100.842,ORFIENS,2)=DUZ
+25 DO UPDATE^DIE("","ORFDA","","ORFERR")
+26 IF $GET(ORFERR)'=""
SET LST(1)="0^Error adding alert recipient "_USR
QUIT
+27 SET ORAUSR(USR)=""
End DoDot:1
IF $GET(ORFERR)'=""
QUIT
+28 SET LST(1)="1^Comments successfully added."
+29 ; send notification to originator and recipients
+30 SET X3=$GET(^OR(100,+ORIFN,8,ORDA,3))
IF $PIECE(X3,U,4)'=""
SET ORAUSR(+$PIECE(X3,U,4))=""
+31 ;don't sent alert to user adding comment
KILL ORFDA,ORAUSR(DUZ)
+32 DO CMTMSG(ORIFN,ORVP,.ORAUSR)
+33 QUIT
+34 ;
CMTMSG(ORIFN,ORVP,ORAUSR) ; send alert notification information to recipients
+1 NEW ORCMSG,ORN,ORDFN,OR3,ORYT
+2 SET ORCMSG="Comment Added to Flagged Order: "
+3 SET ORN=8
SET ORDFN=+ORVP
SET OR3=$GET(^OR(100,+ORIFN,3))
+4 DO TEXT^ORQ12(.ORYT,+ORIFN_";"_+$PIECE(OR3,U,7),20)
+5 SET ORCMSG=ORCMSG_$GET(ORYT(1))
+6 DO EN^ORB3(ORN,ORDFN,+ORIFN,.ORAUSR,ORCMSG)
+7 QUIT
FLGCOM(LST,ORIFN) ; flag comments, get
+1 NEW DA,CNT,X,Y,ORZ,DIWL,DIWR,DIWF,DATA,I
+2 SET DA=$PIECE(ORIFN,";",2)
SET (CNT,Y)=0
+3 if $DATA(^OR(100,+ORIFN,8,DA,3))
Begin DoDot:1
+4 if $GET(ACTION)=""
QUIT
+5 NEW BFLAG
SET BFLAG=$GET(^OR(100,+ORIFN,8,DA,3))
+6 SET CNT=CNT+1
SET LST(CNT)="<COMMENT>"
+7 SET CNT=CNT+1
SET LST(CNT)=$PIECE(BFLAG,U,3)_";"_$$DATE^ORQ20($PIECE(BFLAG,U,3))_U_$PIECE(BFLAG,U,4)_";"_$$USER^ORQ20($PIECE(BFLAG,U,4))
+8 SET CNT=CNT+1
SET LST(CNT)="Flagged Reason: "_$PIECE(BFLAG,U,5)
+9 SET CNT=CNT+1
SET LST(CNT)="</COMMENT>"
End DoDot:1
+10 SET DIWL=1
SET DIWR=70
SET DIWF="C70"
KILL ^UTILITY($JOB,"W")
+11 FOR
SET Y=$ORDER(^OR(100,+ORIFN,8,DA,9,Y))
if 'Y
QUIT
Begin DoDot:1
+12 SET DATA=$GET(^OR(100,+ORIFN,8,DA,9,Y,0))
+13 SET CNT=CNT+1
SET LST(CNT)="<COMMENT>"
+14 SET CNT=CNT+1
SET LST(CNT)=$PIECE(DATA,U)_";"_$$DATE^ORQ20($PIECE(DATA,U))_U_$PIECE(DATA,U,2)_";"_$$USER^ORQ20($PIECE(DATA,U,2))
+15 SET ORZ=0
FOR
SET ORZ=$ORDER(^OR(100,+ORIFN,8,DA,9,Y,"COM",ORZ))
if 'ORZ
QUIT
SET X=^(ORZ,0)
DO ^DIWP
+16 SET I=0
FOR
SET I=$ORDER(^UTILITY($JOB,"W",DIWL,I))
if 'I
QUIT
SET CNT=CNT+1
SET LST(CNT)=^(I,0)
+17 SET CNT=CNT+1
SET LST(CNT)="</COMMENT>"
+18 KILL ^UTILITY($JOB,"W")
End DoDot:1
+19 QUIT
FLGHST(ORY,ORIFN) ;archive history of flag order
+1 NEW X3,F,Y
+2 NEW ORI,X3,CNT,ORJ
+3 SET ORI=$PIECE(ORIFN,";",2)
SET CNT=0
+4 ;Un-/Flagged
IF $DATA(^OR(100,+ORIFN,8,ORI,3))
Begin DoDot:1
+5 SET X3=$GET(^OR(100,+ORIFN,8,ORI,3))
+6 SET CNT=CNT+1
SET ORY(CNT)="Flagged by: "_$$USER^ORQ20(+$PIECE(X3,U,4))_" on "_$$DATE^ORQ20($PIECE(X3,U,3))
+7 SET CNT=CNT+1
SET ORY(CNT)=" "_$PIECE(X3,U,5)
+8 IF $PIECE(X3,U,10)'=""
SET CNT=CNT+1
SET ORY(CNT)="No Action Alert: "_$$DATE^ORQ20($PIECE(X3,U,10))
End DoDot:1
+9 ;flagged recipients
+10 SET ORJ=0
SET F=0
FOR
SET ORJ=$ORDER(^OR(100,+ORIFN,8,ORI,6,ORJ))
if 'ORJ
QUIT
SET Y=^(ORJ,0)
Begin DoDot:1
+11 SET CNT=CNT+1
SET ORY(CNT)=$SELECT('F:"Recipients: ",1:" ")_$$USER^ORQ20(+Y)_" added on "_$$DATE^ORQ20($PIECE(Y,U,2))_" by "_$$USER^ORQ20(+$PIECE(Y,U,3))
SET F=1
End DoDot:1
+12 ;flagged comments
+13 NEW DIWL,DIWR,DIWF,X,I,ORK
+14 SET ORJ=0
SET F=0
FOR
SET ORJ=$ORDER(^OR(100,+ORIFN,8,ORI,9,ORJ))
if 'ORJ
QUIT
SET Y=^(ORJ,0)
Begin DoDot:1
+15 SET CNT=CNT+1
SET ORY(CNT)=$SELECT('F:"Comments by: ",1:" ")_$$USER^ORQ20($PIECE(Y,U,2))_"on "_$$DATE^ORQ20(+Y)
SET F=1
+16 SET DIWL=19
SET DIWR=110
SET DIWF="I19"
KILL ^UTILITY($JOB,"W")
+17 SET ORK=0
FOR
SET ORK=$ORDER(^OR(100,+ORIFN,8,ORI,9,ORJ,"COM",ORK))
if 'ORK
QUIT
SET X=^(ORK,0)
DO ^DIWP
+18 SET I=0
FOR
SET I=$ORDER(^UTILITY($JOB,"W",DIWL,I))
if 'I
QUIT
SET CNT=CNT+1
SET ORY(CNT)=^(I,0)
End DoDot:1
+19 KILL ^UTILITY($JOB,"W")
+20 IF $PIECE($GET(X3),U)=0
Begin DoDot:1
+21 SET CNT=CNT+1
SET ORY(CNT)="Unflagged by: "_$$USER^ORQ20(+$PIECE(X3,U,7))_" on "_$$DATE^ORQ20($PIECE(X3,U,6))
+22 SET CNT=CNT+1
SET ORY(CNT)=" "_$PIECE(X3,U,8)
End DoDot:1
+23 KILL ^UTILITY($JOB,"W")
+24 QUIT
GETHST(ORFH,ORIFN) ;Get flag order history
+1 NEW ORI,ORJ,ORK,CNT,Y
+2 SET ORI=$PIECE(ORIFN,";",2)
SET CNT=0
+3 IF $DATA(^OR(100,+ORIFN,8,ORI,"FHIS"))
Begin DoDot:1
+4 SET ORJ=0
FOR
SET ORJ=$ORDER(^OR(100,+ORIFN,8,ORI,"FHIS",ORJ))
if 'ORJ
QUIT
SET ORK=0
Begin DoDot:2
+5 SET ORK=0
FOR
SET ORK=$ORDER(^OR(100,+ORIFN,8,ORI,"FHIS",ORJ,"COM",ORK))
if 'ORK
QUIT
SET Y=^(ORK,0)
SET CNT=CNT+1
SET ORFH(CNT)=Y
End DoDot:2
End DoDot:1
+6 QUIT
SCHALRT(ORVP,ORIFN,OREXP) ;schedule alert in file #100.97
+1 NEW ORDATA,ORDA3,ORACT,ORYT,ORNAM
+2 IF (ORVP="")!(ORIFN="")!(OREXP)=""
QUIT
+3 SET ORACT=$PIECE(ORIFN,";",2)
+4 SET ORDA3=$GET(^OR(100,+ORIFN,8,ORACT,3))
+5 SET ORDATA("PATIENT")=ORVP
+6 SET ORDATA("WHEN")=OREXP
+7 SET ORDATA("WHO")=$PIECE(ORDA3,U,4)
+8 SET ORDATA("ALERT")="98;ORD(100.9,"
+9 SET ORNAM=$$OI^ORX8(ORIFN)
+10 SET ORDATA("TITLE")="Order flag expired for "_$PIECE(ORNAM,"^",2)_" on "_$$DATE^ORQ20(OREXP)
+11 SET ORDATA("IFN")=ORIFN
+12 DO SCHALRT^ORB3UTL(.ORDATA)
+13 QUIT
+14 ;
FLAGTXTS(CLST,IFNS) ; get flag reason for list of orders
+1 NEW L,DA,IFN,CNT
+2 SET (CNT,L)=0
+3 FOR
SET L=$ORDER(IFNS(L))
if 'L
QUIT
SET IFN=IFNS(L)
Begin DoDot:1
+4 SET DA=$SELECT($PIECE(IFN,";",2):$PIECE(IFN,";",2),1:1)
SET IFN=+IFN
+5 DO FLRSON
End DoDot:1
+6 QUIT
+7 ;
FLRSON ; flag reason
+1 NEW FLAG,I,F,ORUSR,ORCOM,Z
+2 SET FLAG=$GET(^OR(100,IFN,8,DA,3))
+3 SET CNT=CNT+1
+4 SET CLST(CNT)="~"_IFN_U_"FLAGGED: "_$$FMTE^XLFDT($PIECE(FLAG,U,3))_" by "_$PIECE($GET(^VA(200,+$PIECE(FLAG,U,4),0)),U)
+5 SET CNT=CNT+1
+6 ; reason
SET CLST(CNT)=$PIECE(FLAG,U,5)
+7 IF $PIECE(FLAG,U,10)'=""
SET CNT=CNT+1
SET CLST(CNT)="NO ACTION ALERT: "_$$FMTE^XLFDT($PIECE(FLAG,U,10))
+8 ; recipients
DO FLAGRCPT^ORWDXA1(.ORUSR,IFNS(L))
+9 SET (I,F)=0
+10 FOR
SET I=$ORDER(ORUSR(I))
if 'I
QUIT
IF ORUSR(I)
Begin DoDot:1
+11 SET CNT=CNT+1
SET CLST(CNT)=$SELECT('F:"RECIPIENTS:"_$CHAR(9),1:$CHAR(9)_$CHAR(9))_$PIECE(ORUSR(I),U,2)
SET F=1
End DoDot:1
+12 ; comments
DO FLGCOM^ORWDXA1(.ORCOM,IFNS(L))
+13 SET (I,F)=0
+14 FOR
SET I=$ORDER(ORCOM(I))
if 'I
QUIT
IF ORCOM(I)="<COMMENT>"
SET I=$ORDER(ORCOM(I))
Begin DoDot:1
+15 SET CNT=CNT+1
SET CLST(CNT)=$SELECT('F:"COMMENTS:"_$CHAR(9),1:$CHAR(9)_$CHAR(9))_$PIECE($PIECE(ORCOM(I),U,2),";",2)_" on "_$PIECE($PIECE(ORCOM(I),U),";",2)
SET F=1
+16 FOR
SET I=$ORDER(ORCOM(I))
if ORCOM(I)="</COMMENT>"
QUIT
Begin DoDot:2
+17 SET CNT=CNT+1
SET CLST(CNT)=$CHAR(9)_ORCOM(I)
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
MAP(Y) ; display group mapping
+1 NEW C,I,X
+2 DO GRP(.X)
+3 SET C=0
SET I=0
+4 FOR
SET I=$ORDER(X(I))
if I=""
QUIT
SET C=C+1
SET Y(I)=X(I)
+5 QUIT
GRP(BYGRP) ;
+1 NEW I,ORY,TOPINFO
+2 DO GETLST^XPAR(.ORY,"ALL","ORWOR CATEGORY SEQUENCE")
+3 SET I=0
FOR
SET I=$ORDER(ORY(I))
if I=""
QUIT
Begin DoDot:1
+4 SET BYGRP($PIECE(ORY(I),U,2))=$PIECE(ORY(I),U,2)
End DoDot:1
+5 SET I=0
FOR
SET I=$ORDER(BYGRP(I))
if I=""
QUIT
SET TOPINFO=BYGRP(I)
DO EXPAND(I)
+6 QUIT
EXPAND(GROUP) ;
+1 NEW I,CHILD
+2 SET I=0
FOR
SET I=$ORDER(^ORD(100.98,GROUP,1,I))
if I<1
QUIT
Begin DoDot:1
+3 SET CHILD=$PIECE(^ORD(100.98,GROUP,1,I,0),"^",1)
+4 IF '$DATA(BYGRP(CHILD))
SET BYGRP(CHILD)=TOPINFO
DO EXPAND(CHILD)
End DoDot:1
+5 QUIT
+6 ;
CHOREXP(IFN) ;
+1 if '$DATA(^OR(100.97,"E",IFN))
QUIT
+2 NEW DA,TD
SET DA=$ORDER(^OR(100.97,"E",IFN,""))
if 'DA
QUIT
+3 SET TD=$PIECE($GET(^OR(100.97,DA,0)),U,3)
if 'TD!($$NOW^XLFDT()>TD)
QUIT
+4 SET DIK="^OR(100.97,"
DO ^DIK
KILL DIK
+5 QUIT
+6 ;
