- ORCFLAG ; SLC/MKB - Flag orders ;12/26/2006
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,243**;Dec 17, 1997;Build 242
- ;
- EN1(ORIFN) ; -- standalone entry point to un/flag order ORIFN
- N ORLK,ORERR,VA,VADM,VAERR,DFN,ORVP,ORPNM,ORSSN,ORAGE,ORACTN,ORPS
- Q:'$G(ORIFN) S:'$P(ORIFN,";",2) ORIFN=+ORIFN_";1"
- S ORVP=$P($G(^OR(100,+ORIFN,0)),U,2),DFN=+ORVP I 'ORVP!'$D(^(8,+$P(ORIFN,";",2),0)) W !,"Missing or invalid order!" H 1 Q
- D DEM^VADPT S ORPNM=VADM(1),ORSSN=$P(VADM(2),U,2),ORAGE=VADM(4)
- S ORACTN=$S($G(^OR(100,+ORIFN,8,+$P(ORIFN,";",2),3)):"UF",1:"FL")
- I '$$VALID^ORCACT0(ORIFN,ORACTN,.ORERR) W !,ORERR H 1 Q
- S ORLK=$$LOCK1^ORX2(+ORIFN) I 'ORLK W !,$P(ORLK,U,2) H 1 Q
- S ORACTN=$S(ORACTN="UF":"UN",1:"EN"),ORPS=1
- D @ORACTN,UNLK1^ORX2(+ORIFN)
- Q
- ;
- EN ; -- Flag order ORIFN
- N OREASON,DA,ORB,ORNP,ORNOW S ORNOW=+$E($$NOW^XLFDT,1,12)
- S DA=$P(ORIFN,";",2) I 'DA W !,"Unable to flag!" H 1 Q
- S OREASON=$$REASON Q:OREASON="^"
- S ORNP=+$P($G(^OR(100,+ORIFN,8,DA,0)),U,3),ORNP=$$PROV(ORNP) Q:ORNP="^"
- D BULLETIN ;use ORNP?
- K ^OR(100,+ORIFN,8,DA,3) S ^(3)="1^"_$G(XMZ)_U_ORNOW_U_DUZ_U_OREASON_"^^^^"_ORNP
- S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT,OREBUILD=1 ; Last Activity
- S ORB=+ORVP_U_+ORIFN_U_ORNP_"^1" D EN^OCXOERR(ORB) ; notification
- W !?10,"... order flagged." H 1 D KILL^XM,MSG(ORIFN)
- Q
- ;
- UN ; -- Unflag order ORIFN
- N OREASON,DA,ORB,ORNP,ORNOW S ORNOW=+$E($$NOW^XLFDT,1,12)
- S DA=$P(ORIFN,";",2) I 'DA W !,"Unable to unflag order!" H 1 Q
- D SHOWFLAG S OREASON=$$COMMENT Q:OREASON="^"
- S $P(^OR(100,+ORIFN,8,DA,3),U)=0,$P(^(3),U,6,8)=ORNOW_U_DUZ_U_OREASON
- S ORNP=+$P(^OR(100,+ORIFN,8,DA,3),U,9) S:'ORNP ORNP=+$P($G(^(0)),U,3)
- S ORB=+ORVP_U_+ORIFN_U_ORNP_"^0" D EN^OCXOERR(ORB) ; notification
- S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT,OREBUILD=1 ; Last Activity
- W !?10,"... order unflagged." H 1 D MSG(ORIFN)
- Q
- ;
- SHOWFLAG ; -- Display [last] flag for order ORIFN
- N FLAG
- S FLAG=$G(^OR(100,+ORIFN,8,DA,3))
- W !," FLAGGED: "_$$LTIM($P(FLAG,U,3))_" by "_$P($G(^VA(200,+$P(FLAG,U,4),0)),U)
- W !?10,$P(FLAG,U,5) ; reason
- Q
- ;
- REASON() ; -- Reason for flag
- N X,Y,DIR
- S DIR(0)="FA^1:80",DIR("A")="REASON FOR FLAG: " ; ck E3R
- S DIR("?")="A reason must be entered to flag this order."
- D ^DIR
- Q Y
- ;
- N X,Y,DIR
- S DIR(0)="FAO^1:80",DIR("A")="COMMENTS: "
- S DIR("?")="A comment may be entered to clarify this order."
- D ^DIR S:$D(DTOUT) Y="^"
- Q Y
- ;
- PROV(ORDR) ; -- Get provider to alert
- N X,Y,DIC
- S DIC=200,DIC(0)="AEQM",DIC("A")="Send alert to: "
- I $G(ORDR) S ORDR=$P($G(^VA(200,+ORDR,0)),U) S:$L(ORDR) DIC("B")=ORDR
- S DIC("S")="N ORT S ORT=$P(^(0),U,11) I 'ORT!(ORT>DT)"
- D ^DIC S:Y>0 Y=+Y I Y'>0 S Y="^"
- Q Y
- ;
- BULLETIN ; -- Send bulletin re: flag
- N OR0,OR3,ORDTXT,XMB,XMY,XMDUZ,ORENT,BULL,ORSRV,ORUSR
- S OR0=$G(^OR(100,+ORIFN,0)),OR3=$G(^(3)) ;ORUSR=+$P(OR0,U,4)
- S ORUSR=+$G(ORNP),ORSRV=+$P($G(^VA(200,ORUSR,5)),U)
- S ORENT="USR.`"_ORUSR_"^SRV.`"_ORSRV_"^DIV^SYS^PKG"
- S BULL=$$GET^XPAR(ORENT,"ORB FLAGGED ORDERS BULLETIN",1,"Q")
- Q:$G(BULL)'="Y" ;quit if parameter value is not 'Y'es
- ;
- W !,"Sending bulletin to "_$P($G(^VA(200,ORUSR,0)),U)_"..."
- S XMB="OR FLAGGED ORDER",XMDUZ=DUZ,XMY(ORUSR)=""
- S XMB(1)=ORPNM,XMB(2)=ORSSN,XMB(3)=ORAGE,XMB(4)=$$LTIM($P(OR0,U,7))
- D TEXT^ORQ12(.ORDTXT,+ORIFN,80)
- S XMB(5)=$G(ORDTXT(1)),XMB(6)=$G(ORDTXT(2)),XMB(7)=$G(ORDTXT(3))
- S XMB(8)=$$LTIM($P(OR0,U,8)),XMB(9)=$$LTIM($P(OR0,U,9)),XMB(10)=OREASON
- S XMB(11)=$P($G(^ORD(100.01,+$P(OR3,U,3),0)),U)
- D EN^XMB
- Q
- ;
- LTIM(X) ; -- format FM date/time into MM/DD HH:MM
- N Y S Y=""
- S:X Y=$E(X,4,5)_"/"_$E(X,6,7)
- S:X["." Y=Y_" "_$E(X_"0",9,10)_":"_$E(X_"000",11,12)
- Q Y
- ;
- MSG(ORDER) ; -- Sends HL7 message to Pharmacy when order is un/flagged
- Q:'$L($T(OBR^PSJHL4)) ;needs PSJ*5*85
- Q:'$G(ORDER) Q:'$D(^OR(100,+ORDER,0)) Q:'$P(ORDER,";",2)
- N OR0,OR3,ORMSG,ORVP,ORX,ORFLAG
- S OR0=$G(^OR(100,+ORDER,0)),OR3=$G(^(8,+$P(ORDER,";",2),3))
- Q:"^PSJ^PSIV^PSO^"'[(U_$$GET1^DIQ(9.4,+$P(OR0,U,14)_",",1)_U) ;Inpt or IV
- S ORMSG(1)=$$MSH^ORMBLD("ORU","PS")
- S ORVP=$P(OR0,U,2),ORMSG(2)=$$PID^ORMBLD(ORVP)
- S ORMSG(3)=$$PV1^ORMBLD(ORVP,$P(OR0,U,12),+$P(OR0,U,10))
- S ORX=$S(OR3:$P(OR3,U,3,5),1:$P(OR3,U,6,8))
- S ORFLAG=$S(OR3:"FL",1:"UF")_"|||"_$$HL7DATE^ORMBLD($P(ORX,U))_"||||||"_$P(ORX,U,3)_"|||"_+$P(ORX,U,2)
- S:$G(ORPS) ORFLAG=ORFLAG_"||||||||PHR" ;action taken by pharmacist
- S ORMSG(4)="OBR|1|"_ORDER_"^OR|"_$G(^OR(100,+ORDER,4))_"^PS|"_ORFLAG
- D MSG^XQOR("OR EVSEND PS",.ORMSG)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCFLAG 4535 printed Mar 13, 2025@21:33:16 Page 2
- ORCFLAG ; SLC/MKB - Flag orders ;12/26/2006
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,243**;Dec 17, 1997;Build 242
- +2 ;
- EN1(ORIFN) ; -- standalone entry point to un/flag order ORIFN
- +1 NEW ORLK,ORERR,VA,VADM,VAERR,DFN,ORVP,ORPNM,ORSSN,ORAGE,ORACTN,ORPS
- +2 if '$GET(ORIFN)
- QUIT
- if '$PIECE(ORIFN,";",2)
- SET ORIFN=+ORIFN_";1"
- +3 SET ORVP=$PIECE($GET(^OR(100,+ORIFN,0)),U,2)
- SET DFN=+ORVP
- IF 'ORVP!'$DATA(^(8,+$PIECE(ORIFN,";",2),0))
- WRITE !,"Missing or invalid order!"
- HANG 1
- QUIT
- +4 DO DEM^VADPT
- SET ORPNM=VADM(1)
- SET ORSSN=$PIECE(VADM(2),U,2)
- SET ORAGE=VADM(4)
- +5 SET ORACTN=$SELECT($GET(^OR(100,+ORIFN,8,+$PIECE(ORIFN,";",2),3)):"UF",1:"FL")
- +6 IF '$$VALID^ORCACT0(ORIFN,ORACTN,.ORERR)
- WRITE !,ORERR
- HANG 1
- QUIT
- +7 SET ORLK=$$LOCK1^ORX2(+ORIFN)
- IF 'ORLK
- WRITE !,$PIECE(ORLK,U,2)
- HANG 1
- QUIT
- +8 SET ORACTN=$SELECT(ORACTN="UF":"UN",1:"EN")
- SET ORPS=1
- +9 DO @ORACTN
- DO UNLK1^ORX2(+ORIFN)
- +10 QUIT
- +11 ;
- EN ; -- Flag order ORIFN
- +1 NEW OREASON,DA,ORB,ORNP,ORNOW
- SET ORNOW=+$EXTRACT($$NOW^XLFDT,1,12)
- +2 SET DA=$PIECE(ORIFN,";",2)
- IF 'DA
- WRITE !,"Unable to flag!"
- HANG 1
- QUIT
- +3 SET OREASON=$$REASON
- if OREASON="^"
- QUIT
- +4 SET ORNP=+$PIECE($GET(^OR(100,+ORIFN,8,DA,0)),U,3)
- SET ORNP=$$PROV(ORNP)
- if ORNP="^"
- QUIT
- +5 ;use ORNP?
- DO BULLETIN
- +6 KILL ^OR(100,+ORIFN,8,DA,3)
- SET ^(3)="1^"_$GET(XMZ)_U_ORNOW_U_DUZ_U_OREASON_"^^^^"_ORNP
- +7 ; Last Activity
- SET $PIECE(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT
- SET OREBUILD=1
- +8 ; notification
- SET ORB=+ORVP_U_+ORIFN_U_ORNP_"^1"
- DO EN^OCXOERR(ORB)
- +9 WRITE !?10,"... order flagged."
- HANG 1
- DO KILL^XM
- DO MSG(ORIFN)
- +10 QUIT
- +11 ;
- UN ; -- Unflag order ORIFN
- +1 NEW OREASON,DA,ORB,ORNP,ORNOW
- SET ORNOW=+$EXTRACT($$NOW^XLFDT,1,12)
- +2 SET DA=$PIECE(ORIFN,";",2)
- IF 'DA
- WRITE !,"Unable to unflag order!"
- HANG 1
- QUIT
- +3 DO SHOWFLAG
- SET OREASON=$$COMMENT
- if OREASON="^"
- QUIT
- +4 SET $PIECE(^OR(100,+ORIFN,8,DA,3),U)=0
- SET $PIECE(^(3),U,6,8)=ORNOW_U_DUZ_U_OREASON
- +5 SET ORNP=+$PIECE(^OR(100,+ORIFN,8,DA,3),U,9)
- if 'ORNP
- SET ORNP=+$PIECE($GET(^(0)),U,3)
- +6 ; notification
- SET ORB=+ORVP_U_+ORIFN_U_ORNP_"^0"
- DO EN^OCXOERR(ORB)
- +7 ; Last Activity
- SET $PIECE(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT
- SET OREBUILD=1
- +8 WRITE !?10,"... order unflagged."
- HANG 1
- DO MSG(ORIFN)
- +9 QUIT
- +10 ;
- SHOWFLAG ; -- Display [last] flag for order ORIFN
- +1 NEW FLAG
- +2 SET FLAG=$GET(^OR(100,+ORIFN,8,DA,3))
- +3 WRITE !," FLAGGED: "_$$LTIM($PIECE(FLAG,U,3))_" by "_$PIECE($GET(^VA(200,+$PIECE(FLAG,U,4),0)),U)
- +4 ; reason
- WRITE !?10,$PIECE(FLAG,U,5)
- +5 QUIT
- +6 ;
- REASON() ; -- Reason for flag
- +1 NEW X,Y,DIR
- +2 ; ck E3R
- SET DIR(0)="FA^1:80"
- SET DIR("A")="REASON FOR FLAG: "
- +3 SET DIR("?")="A reason must be entered to flag this order."
- +4 DO ^DIR
- +5 QUIT Y
- +6 ;
- +1 NEW X,Y,DIR
- +2 SET DIR(0)="FAO^1:80"
- SET DIR("A")="COMMENTS: "
- +3 SET DIR("?")="A comment may be entered to clarify this order."
- +4 DO ^DIR
- if $DATA(DTOUT)
- SET Y="^"
- +5 QUIT Y
- +6 ;
- PROV(ORDR) ; -- Get provider to alert
- +1 NEW X,Y,DIC
- +2 SET DIC=200
- SET DIC(0)="AEQM"
- SET DIC("A")="Send alert to: "
- +3 IF $GET(ORDR)
- SET ORDR=$PIECE($GET(^VA(200,+ORDR,0)),U)
- if $LENGTH(ORDR)
- SET DIC("B")=ORDR
- +4 SET DIC("S")="N ORT S ORT=$P(^(0),U,11) I 'ORT!(ORT>DT)"
- +5 DO ^DIC
- if Y>0
- SET Y=+Y
- IF Y'>0
- SET Y="^"
- +6 QUIT Y
- +7 ;
- BULLETIN ; -- Send bulletin re: flag
- +1 NEW OR0,OR3,ORDTXT,XMB,XMY,XMDUZ,ORENT,BULL,ORSRV,ORUSR
- +2 ;ORUSR=+$P(OR0,U,4)
- SET OR0=$GET(^OR(100,+ORIFN,0))
- SET OR3=$GET(^(3))
- +3 SET ORUSR=+$GET(ORNP)
- SET ORSRV=+$PIECE($GET(^VA(200,ORUSR,5)),U)
- +4 SET ORENT="USR.`"_ORUSR_"^SRV.`"_ORSRV_"^DIV^SYS^PKG"
- +5 SET BULL=$$GET^XPAR(ORENT,"ORB FLAGGED ORDERS BULLETIN",1,"Q")
- +6 ;quit if parameter value is not 'Y'es
- if $GET(BULL)'="Y"
- QUIT
- +7 ;
- +8 WRITE !,"Sending bulletin to "_$PIECE($GET(^VA(200,ORUSR,0)),U)_"..."
- +9 SET XMB="OR FLAGGED ORDER"
- SET XMDUZ=DUZ
- SET XMY(ORUSR)=""
- +10 SET XMB(1)=ORPNM
- SET XMB(2)=ORSSN
- SET XMB(3)=ORAGE
- SET XMB(4)=$$LTIM($PIECE(OR0,U,7))
- +11 DO TEXT^ORQ12(.ORDTXT,+ORIFN,80)
- +12 SET XMB(5)=$GET(ORDTXT(1))
- SET XMB(6)=$GET(ORDTXT(2))
- SET XMB(7)=$GET(ORDTXT(3))
- +13 SET XMB(8)=$$LTIM($PIECE(OR0,U,8))
- SET XMB(9)=$$LTIM($PIECE(OR0,U,9))
- SET XMB(10)=OREASON
- +14 SET XMB(11)=$PIECE($GET(^ORD(100.01,+$PIECE(OR3,U,3),0)),U)
- +15 DO EN^XMB
- +16 QUIT
- +17 ;
- LTIM(X) ; -- format FM date/time into MM/DD HH:MM
- +1 NEW Y
- SET Y=""
- +2 if X
- SET Y=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)
- +3 if X["."
- SET Y=Y_" "_$EXTRACT(X_"0",9,10)_":"_$EXTRACT(X_"000",11,12)
- +4 QUIT Y
- +5 ;
- MSG(ORDER) ; -- Sends HL7 message to Pharmacy when order is un/flagged
- +1 ;needs PSJ*5*85
- if '$LENGTH($TEXT(OBR^PSJHL4))
- QUIT
- +2 if '$GET(ORDER)
- QUIT
- if '$DATA(^OR(100,+ORDER,0))
- QUIT
- if '$PIECE(ORDER,";",2)
- QUIT
- +3 NEW OR0,OR3,ORMSG,ORVP,ORX,ORFLAG
- +4 SET OR0=$GET(^OR(100,+ORDER,0))
- SET OR3=$GET(^(8,+$PIECE(ORDER,";",2),3))
- +5 ;Inpt or IV
- if "^PSJ^PSIV^PSO^"'[(U_$$GET1^DIQ(9.4,+$PIECE(OR0,U,14)_",",1)_U)
- QUIT
- +6 SET ORMSG(1)=$$MSH^ORMBLD("ORU","PS")
- +7 SET ORVP=$PIECE(OR0,U,2)
- SET ORMSG(2)=$$PID^ORMBLD(ORVP)
- +8 SET ORMSG(3)=$$PV1^ORMBLD(ORVP,$PIECE(OR0,U,12),+$PIECE(OR0,U,10))
- +9 SET ORX=$SELECT(OR3:$PIECE(OR3,U,3,5),1:$PIECE(OR3,U,6,8))
- +10 SET ORFLAG=$SELECT(OR3:"FL",1:"UF")_"|||"_$$HL7DATE^ORMBLD($PIECE(ORX,U))_"||||||"_$PIECE(ORX,U,3)_"|||"_+$PIECE(ORX,U,2)
- +11 ;action taken by pharmacist
- if $GET(ORPS)
- SET ORFLAG=ORFLAG_"||||||||PHR"
- +12 SET ORMSG(4)="OBR|1|"_ORDER_"^OR|"_$GET(^OR(100,+ORDER,4))_"^PS|"_ORFLAG
- +13 DO MSG^XQOR("OR EVSEND PS",.ORMSG)
- +14 QUIT