- 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 Jan 18, 2025@03:37:04 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 ;