- ORMPS2 ;SLC/MKB - Process Pharmacy ORM msgs cont ;04/01/2008
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,116,129,134,186,190,195,215,265,243**;Dec 17, 1997;Build 242
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- FINISHED() ; -- new order [SN^ORMPS] due to finishing?
- N Y,ORIG,TYPE,ORIG4 S Y=0
- S ORIG=+$P(ZRX,"|",2),TYPE=$P(ZRX,"|",4),ORIG4=$G(^OR(100,ORIG,4))
- I ORIG,TYPE="E",ORIG4?1.N1"P"!(ORIG4?1.N1"S") S ORIFN=+ORIG,Y=1
- Q Y
- ;
- WPX() ; -- Compare comments in @ORMSG@(NTE) with order ORIFN
- ; Returns 1 if different, or 0 if same
- N NTE,SPINST,Y,X S Y=0
- S NTE=+$$NTE^ORMPS3(21),SPINST=$S(NTE:$$NTXT^ORMPS3(NTE),1:"")
- S X=$$VALTXT^ORMPS3(+ORIFN,"COMMENT")
- I $TR(X," ")'=$TR(SPINST," ") S Y=1 ;comp text w/o spaces
- WQ Q Y
- ;
- IVX() ; -- Compare ORMSG to Inpt order ORIFN if IV, return 0 if 'diff or 'IV
- N Y,RXC,DG,OI,PSOI,XC,X,RATE,RXR,ORA,ORB,ORX,I,J,OI0,INST,VOL,STR,UNT
- S RXC=$$RXC^ORMPS,Y=0 I RXC'>0 Q Y ;not IV of any kind
- S DG=+$P($G(^OR(100,+ORIFN,0)),U,11),DG=$P($G(^ORD(100.98,DG,0)),U,3)
- I DG'="IV RX",DG'="TPN" D Q Y ;not fluid
- . I $P(ZRX,"|",7)'="" S Y=1 Q
- . I $$NUMADDS^ORMPS3>1 S Y=1 Q
- . S OI=$$VALUE("ORDERABLE"),PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2)
- . S XC=@ORMSG@(RXC) I PSOI'=$P(XC,U,4) S Y=1 Q
- . N X1,X2,X3 S X1=$P(XC,"|",4),X2=$P($P(XC,"|",5),U,5)
- . S X3=$$VALUE("INSTR") I (X1_X2)'=X3,(X1_" "_X2)'=X3 S Y=1 Q
- IV1 S RATE=$$FIND^ORM(+RXE,24),UNT=$P($$FIND^ORM(+RXE,25),U,5)
- S:$L(UNT) RATE=RATE_" "_UNT S X=$$VALUE("RATE") I RATE'=X D Q:Y Y
- . S:RATE["@" RATE=$P(RATE,"@") S:X["@" X=$P(X,"@") ;rate@labels
- . I RATE'=X S Y=1 Q
- I $P(ZRX,"|",7)'=$$VALUE("TYPE") S Y=1 Q Y
- S RXR=$$RXR^ORMPS
- I $P($P(RXR,"|",2),U,4)'=$$VALUE("ROUTE") S Y=1 Q Y
- S ORB=+$$PTR("ORDERABLE ITEM"),ORA=+$$PTR("ADDITIVE"),I=+RXC
- F S XC=@ORMSG@(I) Q:$E(XC,1,3)'="RXC" D S I=$O(@ORMSG@(I)) Q:I'>0
- . S ORX($P(XC,"|",2),+$P(XC,U,4))=$P(XC,"|",4)_U_$P($P(XC,"|",5),U,5)
- . ;ORX("A",PSOI)=str^units or ORX("B",PSOI)=volume^units
- F I="STRENGTH","UNITS","VOLUME" D ;ORX(I,inst)=value
- . S J=0 F S J=$O(^OR(100,+ORIFN,4.5,"ID",I,J)) Q:J'>0 D
- .. S INST=+$P($G(^OR(100,+ORIFN,4.5,J,0)),U,3)
- .. S:INST ORX(I,INST)=$G(^OR(100,+ORIFN,4.5,J,1))
- S I=0 F S I=$O(^OR(100,+ORIFN,4.5,"ID","ORDERABLE",I)) Q:I'>0 D Q:Y
- . S OI0=$G(^OR(100,+ORIFN,4.5,I,0)),OI=+$G(^(1))
- . S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2)
- . I $P(OI0,U,2)=ORA,$G(ORX("A",PSOI)) D Q
- .. S INST=$P(OI0,U,3),STR=+ORX("A",PSOI),UNT=$P(ORX("A",PSOI),U,2)
- .. I STR'=$G(ORX("STRENGTH",INST)) S Y=1 Q
- .. I UNT'=$G(ORX("UNITS",INST)) S Y=1 Q
- .. K ORX("A",PSOI) ;same
- . I $P(OI0,U,2)=ORB,$G(ORX("B",PSOI)) D Q
- .. S INST=$P(OI0,U,3),VOL=+$G(ORX("B",PSOI))
- .. I VOL'=$G(ORX("VOLUME",INST)) S Y=1 Q
- .. K ORX("B",PSOI) ;same
- . S Y=1
- I $O(ORX("A",0))!$O(ORX("B",0)) S Y=1 ;leftover items - changed
- Q Y
- ;
- CHANGED() ; -- Compare ORMSG to order ORIFN, return 1 if different
- N I,X,Y,X1,NTE,SIG,PI,TRXO S Y=0
- I $G(ORCAT)="I" D G CHQ
- . I $$WPX S Y=1 Q ;Special Instructions
- . S X=$$VALUE("DAYS") ;duration
- . I $G(X)'="" D I $G(X)'=X1 S Y=1 Q
- . .S X=$$HL7IVLMT^ORMBLDP1(X)
- . .S TRXO=$$RXO^ORMPS,X1=$P($P($G(TRXO),"|",2),U,3)
- . .;S X1=$$DURATION^ORMPS3($P($P(TRXO,"|",2),U,3))
- . I $$IVX S Y=1 Q ;IV fields
- ;S X=+$P($P(RXE,"|",3),U,4) I X'=+$$VALUE("DRUG") S Y=1 G CHQ
- I +$P(RXE,"|",11)'=+$$VALUE("QTY") S Y=1 G CHQ
- I +$P(RXE,"|",13)'=+$$VALUE("REFILLS") S Y=1 G CHQ
- ;S X=$P(RXE,"|",23) S:$E(X)="D" X=+$E(X,2,99) I X'=+$$VALUE("SUPPLY") S Y=1 G CHQ
- ;I $P(ZRX,"|",5)'=$$VALUE("PICKUP") S Y=1 G CHQ
- S NTE=$$NTE^ORMPS3(21),SIG=+$O(^OR(100,+ORIFN,4.5,"ID","SIG",0)) ;verb
- I NTE,SIG,$P($P(@ORMSG@(NTE),"|",4)," ")'=$P($G(^OR(100,+ORIFN,4.5,SIG,2,1,0))," ") S Y=1 G CHQ
- S NTE=$$NTE^ORMPS3(7),PI=+$O(^OR(100,+ORIFN,4.5,"ID","PI",0))
- I (NTE&'PI)!('NTE&PI) Q 1 ;added or deleted
- I NTE,PI D G CHQ ;compare text
- . S PI=$$VALTXT^ORMPS3(+ORIFN,PI)_$$VALTXT^ORMPS3(+ORIFN,"COMMENT")
- . S NTE=$$NTXT^ORMPS3(NTE)
- . I $TR(NTE," ")'=$TR(PI," ") S Y=1 Q ;comp text w/o spaces
- CHQ Q Y
- ;
- VALUE(ID) ; -- Return value of ID in ^OR(100,+ORIFN,4.5,"ID")
- N I,Y I '$L($G(ID)) Q ""
- S I=+$O(^OR(100,+ORIFN,4.5,"ID",ID,0))
- S Y=$G(^OR(100,+ORIFN,4.5,I,1))
- Q Y
- ;
- PTR(X) ; -- Return ptr to prompt OR GTX X
- Q +$O(^ORD(101.41,"AB","OR GTX "_X,0))
- ;
- RO ; -- Replacement order (finished)
- N RXO,RXC,ORDIALOG,ORDG,ORPKG,ORDA,ORX,ORSIG,ORP,ZSC,NEWSTS
- N ADMIN,IVTYPE
- K ^TMP("ORWORD",$J)
- I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q
- I 'RXE S ORERR="Missing or invalid RXE segment" Q
- S RXO=$$RXO^ORMPS,RXC=$$RXC^ORMPS,ORIFN=+$G(ORIFN)
- I ORIFN'>0 S ORERR="Missing or invalid order number" Q
- D @($S(RXC:"IV",$G(ORCAT)="I":"UDOSE",1:"OUT")_"^ORMPS1") Q:$D(ORERR)
- ;Check keep Admin Time with order if not define in the RXE segment on
- ;verify
- I RXC,$$VALUE("TYPE")="I" S ORDIALOG($$PTR("ADMIN TIMES"),1)=$$VALUE("ADMIN")
- S ORDA=$$ACTION^ORCSAVE("XX",ORIFN,ORNP,"",ORNOW,ORWHO)
- I ORDA'>0 S ORERR="Cannot create new order action" Q
- RO1 ; -Update sts of order to active, last action to dc/edit:
- S ORX=ORDA F S ORX=+$O(^OR(100,ORIFN,8,ORX),-1) Q:ORX'>0 I $D(^(ORX,0)),$P(^(0),U,15)="" Q ;ORX=last released action
- S:ORX $P(^OR(100,ORIFN,8,ORX,0),U,15)=12 ;dc/edit
- S $P(^OR(100,ORIFN,3),U,7)=ORDA,NEWSTS=$S('$G(ORSTS):0,ORSTS=$P(^(3),U,3):0,1:1) K ^(6)
- D STATUS^ORCSAVE2(ORIFN,ORSTS):NEWSTS,SETALL^ORDD100(ORIFN):'NEWSTS
- D DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP)
- D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,ORWHO,ORNATR)
- ; -If unsigned edit, leave XX unsigned & mark ORX as Sig Not Req'd
- S ORSIG=$S($P($G(^OR(100,ORIFN,8,ORX,0)),U,4)'=2:1,1:0)
- D SIGSTS^ORCSAVE2(ORIFN,ORDA):ORSIG,SIGN^ORCSAVE2(ORIFN,,,5,ORX):'ORSIG
- RO2 ; -Update responses, get/save new order text:
- K ^OR(100,ORIFN,4.5) D RESPONSE^ORCSAVE,ORDTEXT^ORCSAVE1(ORIFN_";"_ORDA)
- S $P(^OR(100,ORIFN,0),U,5)=ORDIALOG_";ORD(101.41,",$P(^(0),U,14)=ORPKG
- ;I $P(^OR(100,ORIFN,0),U,11)'=ORDG D ;update DG,xrefs
- ;AGP Changes to handle IMO IV orders CPRS 26v43
- I $P(^OR(100,ORIFN,0),U,11)'=ORDG,$P(^OR(100,ORIFN,0),U,11)'=$O(^ORD(100.98,"B","CLINIC ORDERS","")) D
- . N DA,DR,DIE
- . S DA=ORIFN,DR="23////"_ORDG,DIE="^OR(100," D ^DIE
- S ^OR(100,ORIFN,4)=PKGIFN,$P(^(8,ORDA,0),U,14)=ORDA
- S ORIFN=ORIFN_";"_ORDA,ORDCNTRL="SN" ;to send NA msg back
- I $G(ORL) S ORP(1)=ORIFN_"^1" D PRINTS^ORWD1(.ORP,+ORL)
- I $G(ORCAT)="O" S ZSC=$$ZSC^ORMPS3 I ZSC,$P(ZSC,"|",2)'?2.3U S ^OR(100,+ORIFN,5)=$TR($P(ZSC,"|",2,9),"|","^") ;1 or 0 instead of [N]SC in #100
- Q
- IVLIM(IVDUR) ;
- I $L(IVDUR) D
- . N DURU,DURV S DURU="",DURV=0
- . S DURU=$E(IVDUR,1),DURV=$E(IVDUR,2,$L(IVDUR))
- . I IVDUR["dose" S DURV=$E(IVDUR,6,$L(IVDUR)),IVDUR="for a total of "_+DURV_$S(+DURV=1:" doses",+DURV>1:" doses",1:" dose") Q
- . I (DURU="D")!(DURU="d") S IVDUR="for "_+DURV_$S(+DURV=1:" day",+DURV>1:" days",1:" day")
- . I (DURU="H")!(DURU="h") S IVDUR="for "_+DURV_$S(+DURV=1:" hours",+DURV>1:" hours",1:" hour")
- . I (DURU="M")!(DURU="m") S IVDUR="with total volume "_+DURV_" ml"
- . I (DURU="L")!(DURU="l") S IVDUR="with total volume "_+DURV_" L"
- Q IVDUR
- UNESC(STRING) ;
- Q $$UNESC^ORHLESC(STRING)
- UNESCARR(ARR) ;
- N I S I="" F S I=$O(@ARR@(I)) Q:'$L(I) D
- .N IND S IND=$S(ARR["(":$E(ARR,0,$L(ARR)-1)_","""_I_""")",1:ARR_"("""_I_""")")
- .N TYPE S TYPE=$D(@ARR@(I))
- .I TYPE=11!(TYPE=10) D UNESCARR(IND)
- .I TYPE=1!(TYPE=11) S @ARR@(I)=$$UNESC(@ARR@(I))
- Q
- PCOMM ; -- Get Provider Comments from previous order, when changed
- N OLD,I
- S OLD=+$G(ORIFN) I OLD<1 S OLD=+$P(ZRX,"|",2) Q:OLD<1
- S I=+$O(^OR(100,OLD,4.5,"ID","COMMENT",0)) Q:I<1
- Q:'$O(^OR(100,OLD,4.5,I,2,0)) ;none
- M ^TMP("ORWORD",$J,PC,1)=^OR(100,OLD,4.5,I,2)
- S ORDIALOG(PC,1)="^TMP(""ORWORD"",$J,"_PC_",1)"
- S ORDIALOG(PC,"FORMAT")="@" ;text in Sig already
- Q
- ORMPS2 ;SLC/MKB - Process Pharmacy ORM msgs cont ;04/01/2008
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,116,129,134,186,190,195,215,265,243**;Dec 17, 1997;Build 242
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- FINISHED() ; -- new order [SN^ORMPS] due to finishing?
- +1 NEW Y,ORIG,TYPE,ORIG4
- SET Y=0
- +2 SET ORIG=+$PIECE(ZRX,"|",2)
- SET TYPE=$PIECE(ZRX,"|",4)
- SET ORIG4=$GET(^OR(100,ORIG,4))
- +3 IF ORIG
- IF TYPE="E"
- IF ORIG4?1.N1"P"!(ORIG4?1.N1"S")
- SET ORIFN=+ORIG
- SET Y=1
- +4 QUIT Y
- +5 ;
- WPX() ; -- Compare comments in @ORMSG@(NTE) with order ORIFN
- +1 ; Returns 1 if different, or 0 if same
- +2 NEW NTE,SPINST,Y,X
- SET Y=0
- +3 SET NTE=+$$NTE^ORMPS3(21)
- SET SPINST=$SELECT(NTE:$$NTXT^ORMPS3(NTE),1:"")
- +4 SET X=$$VALTXT^ORMPS3(+ORIFN,"COMMENT")
- +5 ;comp text w/o spaces
- IF $TRANSLATE(X," ")'=$TRANSLATE(SPINST," ")
- SET Y=1
- WQ QUIT Y
- +1 ;
- IVX() ; -- Compare ORMSG to Inpt order ORIFN if IV, return 0 if 'diff or 'IV
- +1 NEW Y,RXC,DG,OI,PSOI,XC,X,RATE,RXR,ORA,ORB,ORX,I,J,OI0,INST,VOL,STR,UNT
- +2 ;not IV of any kind
- SET RXC=$$RXC^ORMPS
- SET Y=0
- IF RXC'>0
- QUIT Y
- +3 SET DG=+$PIECE($GET(^OR(100,+ORIFN,0)),U,11)
- SET DG=$PIECE($GET(^ORD(100.98,DG,0)),U,3)
- +4 ;not fluid
- IF DG'="IV RX"
- IF DG'="TPN"
- Begin DoDot:1
- +5 IF $PIECE(ZRX,"|",7)'=""
- SET Y=1
- QUIT
- +6 IF $$NUMADDS^ORMPS3>1
- SET Y=1
- QUIT
- +7 SET OI=$$VALUE("ORDERABLE")
- SET PSOI=+$PIECE($GET(^ORD(101.43,+OI,0)),U,2)
- +8 SET XC=@ORMSG@(RXC)
- IF PSOI'=$PIECE(XC,U,4)
- SET Y=1
- QUIT
- +9 NEW X1,X2,X3
- SET X1=$PIECE(XC,"|",4)
- SET X2=$PIECE($PIECE(XC,"|",5),U,5)
- +10 SET X3=$$VALUE("INSTR")
- IF (X1_X2)'=X3
- IF (X1_" "_X2)'=X3
- SET Y=1
- QUIT
- End DoDot:1
- QUIT Y
- IV1 SET RATE=$$FIND^ORM(+RXE,24)
- SET UNT=$PIECE($$FIND^ORM(+RXE,25),U,5)
- +1 IF $LENGTH(UNT)
- SET RATE=RATE_" "_UNT
- SET X=$$VALUE("RATE")
- IF RATE'=X
- Begin DoDot:1
- +2 ;rate@labels
- IF RATE["@"
- SET RATE=$PIECE(RATE,"@")
- IF X["@"
- SET X=$PIECE(X,"@")
- +3 IF RATE'=X
- SET Y=1
- QUIT
- End DoDot:1
- IF Y
- QUIT Y
- +4 IF $PIECE(ZRX,"|",7)'=$$VALUE("TYPE")
- SET Y=1
- QUIT Y
- +5 SET RXR=$$RXR^ORMPS
- +6 IF $PIECE($PIECE(RXR,"|",2),U,4)'=$$VALUE("ROUTE")
- SET Y=1
- QUIT Y
- +7 SET ORB=+$$PTR("ORDERABLE ITEM")
- SET ORA=+$$PTR("ADDITIVE")
- SET I=+RXC
- +8 FOR
- SET XC=@ORMSG@(I)
- IF $EXTRACT(XC,1,3)'="RXC"
- QUIT
- Begin DoDot:1
- +9 SET ORX($PIECE(XC,"|",2),+$PIECE(XC,U,4))=$PIECE(XC,"|",4)_U_$PIECE($PIECE(XC,"|",5),U,5)
- +10 ;ORX("A",PSOI)=str^units or ORX("B",PSOI)=volume^units
- End DoDot:1
- SET I=$ORDER(@ORMSG@(I))
- IF I'>0
- QUIT
- +11 ;ORX(I,inst)=value
- FOR I="STRENGTH","UNITS","VOLUME"
- Begin DoDot:1
- +12 SET J=0
- FOR
- SET J=$ORDER(^OR(100,+ORIFN,4.5,"ID",I,J))
- IF J'>0
- QUIT
- Begin DoDot:2
- +13 SET INST=+$PIECE($GET(^OR(100,+ORIFN,4.5,J,0)),U,3)
- +14 IF INST
- SET ORX(I,INST)=$GET(^OR(100,+ORIFN,4.5,J,1))
- End DoDot:2
- End DoDot:1
- +15 SET I=0
- FOR
- SET I=$ORDER(^OR(100,+ORIFN,4.5,"ID","ORDERABLE",I))
- IF I'>0
- QUIT
- Begin DoDot:1
- +16 SET OI0=$GET(^OR(100,+ORIFN,4.5,I,0))
- SET OI=+$GET(^(1))
- +17 SET PSOI=+$PIECE($GET(^ORD(101.43,OI,0)),U,2)
- +18 IF $PIECE(OI0,U,2)=ORA
- IF $GET(ORX("A",PSOI))
- Begin DoDot:2
- +19 SET INST=$PIECE(OI0,U,3)
- SET STR=+ORX("A",PSOI)
- SET UNT=$PIECE(ORX("A",PSOI),U,2)
- +20 IF STR'=$GET(ORX("STRENGTH",INST))
- SET Y=1
- QUIT
- +21 IF UNT'=$GET(ORX("UNITS",INST))
- SET Y=1
- QUIT
- +22 ;same
- KILL ORX("A",PSOI)
- End DoDot:2
- QUIT
- +23 IF $PIECE(OI0,U,2)=ORB
- IF $GET(ORX("B",PSOI))
- Begin DoDot:2
- +24 SET INST=$PIECE(OI0,U,3)
- SET VOL=+$GET(ORX("B",PSOI))
- +25 IF VOL'=$GET(ORX("VOLUME",INST))
- SET Y=1
- QUIT
- +26 ;same
- KILL ORX("B",PSOI)
- End DoDot:2
- QUIT
- +27 SET Y=1
- End DoDot:1
- IF Y
- QUIT
- +28 ;leftover items - changed
- IF $ORDER(ORX("A",0))!$ORDER(ORX("B",0))
- SET Y=1
- +29 QUIT Y
- +30 ;
- CHANGED() ; -- Compare ORMSG to order ORIFN, return 1 if different
- +1 NEW I,X,Y,X1,NTE,SIG,PI,TRXO
- SET Y=0
- +2 IF $GET(ORCAT)="I"
- Begin DoDot:1
- +3 ;Special Instructions
- IF $$WPX
- SET Y=1
- QUIT
- +4 ;duration
- SET X=$$VALUE("DAYS")
- +5 IF $GET(X)'=""
- Begin DoDot:2
- +6 SET X=$$HL7IVLMT^ORMBLDP1(X)
- +7 SET TRXO=$$RXO^ORMPS
- SET X1=$PIECE($PIECE($GET(TRXO),"|",2),U,3)
- +8 ;S X1=$$DURATION^ORMPS3($P($P(TRXO,"|",2),U,3))
- End DoDot:2
- IF $GET(X)'=X1
- SET Y=1
- QUIT
- +9 ;IV fields
- IF $$IVX
- SET Y=1
- QUIT
- End DoDot:1
- GOTO CHQ
- +10 ;S X=+$P($P(RXE,"|",3),U,4) I X'=+$$VALUE("DRUG") S Y=1 G CHQ
- +11 IF +$PIECE(RXE,"|",11)'=+$$VALUE("QTY")
- SET Y=1
- GOTO CHQ
- +12 IF +$PIECE(RXE,"|",13)'=+$$VALUE("REFILLS")
- SET Y=1
- GOTO CHQ
- +13 ;S X=$P(RXE,"|",23) S:$E(X)="D" X=+$E(X,2,99) I X'=+$$VALUE("SUPPLY") S Y=1 G CHQ
- +14 ;I $P(ZRX,"|",5)'=$$VALUE("PICKUP") S Y=1 G CHQ
- +15 ;verb
- SET NTE=$$NTE^ORMPS3(21)
- SET SIG=+$ORDER(^OR(100,+ORIFN,4.5,"ID","SIG",0))
- +16 IF NTE
- IF SIG
- IF $PIECE($PIECE(@ORMSG@(NTE),"|",4)," ")'=$PIECE($GET(^OR(100,+ORIFN,4.5,SIG,2,1,0))," ")
- SET Y=1
- GOTO CHQ
- +17 SET NTE=$$NTE^ORMPS3(7)
- SET PI=+$ORDER(^OR(100,+ORIFN,4.5,"ID","PI",0))
- +18 ;added or deleted
- IF (NTE&'PI)!('NTE&PI)
- QUIT 1
- +19 ;compare text
- IF NTE
- IF PI
- Begin DoDot:1
- +20 SET PI=$$VALTXT^ORMPS3(+ORIFN,PI)_$$VALTXT^ORMPS3(+ORIFN,"COMMENT")
- +21 SET NTE=$$NTXT^ORMPS3(NTE)
- +22 ;comp text w/o spaces
- IF $TRANSLATE(NTE," ")'=$TRANSLATE(PI," ")
- SET Y=1
- QUIT
- End DoDot:1
- GOTO CHQ
- CHQ QUIT Y
- +1 ;
- VALUE(ID) ; -- Return value of ID in ^OR(100,+ORIFN,4.5,"ID")
- +1 NEW I,Y
- IF '$LENGTH($GET(ID))
- QUIT ""
- +2 SET I=+$ORDER(^OR(100,+ORIFN,4.5,"ID",ID,0))
- +3 SET Y=$GET(^OR(100,+ORIFN,4.5,I,1))
- +4 QUIT Y
- +5 ;
- PTR(X) ; -- Return ptr to prompt OR GTX X
- +1 QUIT +$ORDER(^ORD(101.41,"AB","OR GTX "_X,0))
- +2 ;
- RO ; -- Replacement order (finished)
- +1 NEW RXO,RXC,ORDIALOG,ORDG,ORPKG,ORDA,ORX,ORSIG,ORP,ZSC,NEWSTS
- +2 NEW ADMIN,IVTYPE
- +3 KILL ^TMP("ORWORD",$JOB)
- +4 IF '$DATA(^VA(200,ORNP,0))
- SET ORERR="Missing or invalid ordering provider"
- QUIT
- +5 IF 'RXE
- SET ORERR="Missing or invalid RXE segment"
- QUIT
- +6 SET RXO=$$RXO^ORMPS
- SET RXC=$$RXC^ORMPS
- SET ORIFN=+$GET(ORIFN)
- +7 IF ORIFN'>0
- SET ORERR="Missing or invalid order number"
- QUIT
- +8 DO @($SELECT(RXC:"IV",$GET(ORCAT)="I":"UDOSE",1:"OUT")_"^ORMPS1")
- IF $DATA(ORERR)
- QUIT
- +9 ;Check keep Admin Time with order if not define in the RXE segment on
- +10 ;verify
- +11 IF RXC
- IF $$VALUE("TYPE")="I"
- SET ORDIALOG($$PTR("ADMIN TIMES"),1)=$$VALUE("ADMIN")
- +12 SET ORDA=$$ACTION^ORCSAVE("XX",ORIFN,ORNP,"",ORNOW,ORWHO)
- +13 IF ORDA'>0
- SET ORERR="Cannot create new order action"
- QUIT
- RO1 ; -Update sts of order to active, last action to dc/edit:
- +1 ;ORX=last released action
- SET ORX=ORDA
- FOR
- SET ORX=+$ORDER(^OR(100,ORIFN,8,ORX),-1)
- IF ORX'>0
- QUIT
- IF $DATA(^(ORX,0))
- IF $PIECE(^(0),U,15)=""
- QUIT
- +2 ;dc/edit
- IF ORX
- SET $PIECE(^OR(100,ORIFN,8,ORX,0),U,15)=12
- +3 SET $PIECE(^OR(100,ORIFN,3),U,7)=ORDA
- SET NEWSTS=$SELECT('$GET(ORSTS):0,ORSTS=$PIECE(^(3),U,3):0,1:1)
- KILL ^(6)
- +4 IF NEWSTS
- DO STATUS^ORCSAVE2(ORIFN,ORSTS)
- IF 'NEWSTS
- DO SETALL^ORDD100(ORIFN)
- +5 DO DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP)
- +6 DO RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,ORWHO,ORNATR)
- +7 ; -If unsigned edit, leave XX unsigned & mark ORX as Sig Not Req'd
- +8 SET ORSIG=$SELECT($PIECE($GET(^OR(100,ORIFN,8,ORX,0)),U,4)'=2:1,1:0)
- +9 IF ORSIG
- DO SIGSTS^ORCSAVE2(ORIFN,ORDA)
- IF 'ORSIG
- DO SIGN^ORCSAVE2(ORIFN,,,5,ORX)
- RO2 ; -Update responses, get/save new order text:
- +1 KILL ^OR(100,ORIFN,4.5)
- DO RESPONSE^ORCSAVE
- DO ORDTEXT^ORCSAVE1(ORIFN_";"_ORDA)
- +2 SET $PIECE(^OR(100,ORIFN,0),U,5)=ORDIALOG_";ORD(101.41,"
- SET $PIECE(^(0),U,14)=ORPKG
- +3 ;I $P(^OR(100,ORIFN,0),U,11)'=ORDG D ;update DG,xrefs
- +4 ;AGP Changes to handle IMO IV orders CPRS 26v43
- +5 IF $PIECE(^OR(100,ORIFN,0),U,11)'=ORDG
- IF $PIECE(^OR(100,ORIFN,0),U,11)'=$ORDER(^ORD(100.98,"B","CLINIC ORDERS",""))
- Begin DoDot:1
- +6 NEW DA,DR,DIE
- +7 SET DA=ORIFN
- SET DR="23////"_ORDG
- SET DIE="^OR(100,"
- DO ^DIE
- End DoDot:1
- +8 SET ^OR(100,ORIFN,4)=PKGIFN
- SET $PIECE(^(8,ORDA,0),U,14)=ORDA
- +9 ;to send NA msg back
- SET ORIFN=ORIFN_";"_ORDA
- SET ORDCNTRL="SN"
- +10 IF $GET(ORL)
- SET ORP(1)=ORIFN_"^1"
- DO PRINTS^ORWD1(.ORP,+ORL)
- +11 ;1 or 0 instead of [N]SC in #100
- IF $GET(ORCAT)="O"
- SET ZSC=$$ZSC^ORMPS3
- IF ZSC
- IF $PIECE(ZSC,"|",2)'?2.3U
- SET ^OR(100,+ORIFN,5)=$TRANSLATE($PIECE(ZSC,"|",2,9),"|","^")
- +12 QUIT
- IVLIM(IVDUR) ;
- +1 IF $LENGTH(IVDUR)
- Begin DoDot:1
- +2 NEW DURU,DURV
- SET DURU=""
- SET DURV=0
- +3 SET DURU=$EXTRACT(IVDUR,1)
- SET DURV=$EXTRACT(IVDUR,2,$LENGTH(IVDUR))
- +4 IF IVDUR["dose"
- SET DURV=$EXTRACT(IVDUR,6,$LENGTH(IVDUR))
- SET IVDUR="for a total of "_+DURV_$SELECT(+DURV=1:" doses",+DURV>1:" doses",1:" dose")
- QUIT
- +5 IF (DURU="D")!(DURU="d")
- SET IVDUR="for "_+DURV_$SELECT(+DURV=1:" day",+DURV>1:" days",1:" day")
- +6 IF (DURU="H")!(DURU="h")
- SET IVDUR="for "_+DURV_$SELECT(+DURV=1:" hours",+DURV>1:" hours",1:" hour")
- +7 IF (DURU="M")!(DURU="m")
- SET IVDUR="with total volume "_+DURV_" ml"
- +8 IF (DURU="L")!(DURU="l")
- SET IVDUR="with total volume "_+DURV_" L"
- End DoDot:1
- +9 QUIT IVDUR
- UNESC(STRING) ;
- +1 QUIT $$UNESC^ORHLESC(STRING)
- UNESCARR(ARR) ;
- +1 NEW I
- SET I=""
- FOR
- SET I=$ORDER(@ARR@(I))
- IF '$LENGTH(I)
- QUIT
- Begin DoDot:1
- +2 NEW IND
- SET IND=$SELECT(ARR["(":$EXTRACT(ARR,0,$LENGTH(ARR)-1)_","""_I_""")",1:ARR_"("""_I_""")")
- +3 NEW TYPE
- SET TYPE=$DATA(@ARR@(I))
- +4 IF TYPE=11!(TYPE=10)
- DO UNESCARR(IND)
- +5 IF TYPE=1!(TYPE=11)
- SET @ARR@(I)=$$UNESC(@ARR@(I))
- End DoDot:1
- +6 QUIT
- PCOMM ; -- Get Provider Comments from previous order, when changed
- +1 NEW OLD,I
- +2 SET OLD=+$GET(ORIFN)
- IF OLD<1
- SET OLD=+$PIECE(ZRX,"|",2)
- IF OLD<1
- QUIT
- +3 SET I=+$ORDER(^OR(100,OLD,4.5,"ID","COMMENT",0))
- IF I<1
- QUIT
- +4 ;none
- IF '$ORDER(^OR(100,OLD,4.5,I,2,0))
- QUIT
- +5 MERGE ^TMP("ORWORD",$JOB,PC,1)=^OR(100,OLD,4.5,I,2)
- +6 SET ORDIALOG(PC,1)="^TMP(""ORWORD"",$J,"_PC_",1)"
- +7 ;text in Sig already
- SET ORDIALOG(PC,"FORMAT")="@"
- +8 QUIT