- ORMGMRC ; SLC/MKB - Process Consult ORM msgs ;Oct 27, 2023@12:13:26
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,26,68,92,153,174,195,255,243,280,350,415,519,535**;Dec 17, 1997;Build 20
- ;Reference to ^VA(200 in ICR #4329
- ;Reference to ^DIE in ICR #10018
- ;Reference to $$NOW^XLFDT in ICR #10103
- ;Reference to $$UP^XLFSTR in ICR #10104
- ;
- EN ; -- entry point for GMRC messges
- I '$L($T(@ORDCNTRL)) Q ;S ORERR="Invalid order control code" Q
- I ORDCNTRL'="SN",ORDCNTRL'="ZP",'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q
- S:ORDCNTRL="OC"&(ORTYPE="ORR") ORDCNTRL="UA" ;new code
- N ORSTS,OREASON1,NTE S ORSTS=$$STATUS(ORDSTS)
- S:'ORLOG ORLOG=$$NOW^XLFDT S:'ORDUZ ORDUZ=DUZ S:$G(DGPMT) ORDUZ=""
- S OREASON=$P(OREASON,U,5),NTE=$O(@ORMSG@(+ORC)),OREASON1=""
- I NTE,$E(@ORMSG@(NTE),1,3)="NTE" S OREASON1=$P(@ORMSG@(NTE),"|",4)
- D @ORDCNTRL
- Q
- ;
- ZP ; -- Purged
- Q:'ORIFN Q:'$D(^OR(100,+ORIFN,0))
- K ^OR(100,+ORIFN,4) I "^3^5^6^8^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(+ORIFN,14) ; Remove pkg reference, sts=lapsed if still active
- Q
- ;
- ZR ; -- Purged as requested [ack]
- D DELETE^ORCSAVE2(+ORIFN)
- Q
- ;
- ZU ; -- Unable to purge [ack]
- S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; update Last Activity
- Q
- ;
- OK ; -- Order accepted, GMRC order # assigned [ack]
- S ^OR(100,+ORIFN,4)=PKGIFN S:'$G(ORSTS) ORSTS=5
- D STATUS^ORCSAVE2(+ORIFN,ORSTS) ; 5=pending
- D DATES^ORCSAVE2(+ORIFN,+$E($$NOW^XLFDT,1,12))
- Q
- ;
- XX ; -- Change order
- N ORDIALOG,ORDG,ORDA,ORX,ORP,ORSIG S:'$L(ORNATR) ORNATR="S"
- D DLG Q:$D(ORERR) Q:'$D(ORDIALOG) S ORIFN=+ORIFN
- S ORDA=$$ACTION^ORCSAVE("XX",ORIFN,ORNP,OREASON1,ORLOG,ORDUZ)
- I ORDA'>0 S ORERR="Cannot create new order action" Q
- ; -Update sts of order to active, last action to dc/edit:
- S ORX=+$P($G(^OR(100,ORIFN,3)),U,7) S:ORX'>0 ORX=+$O(^(8,ORDA),-1)
- I $D(^OR(100,ORIFN,8,ORX,0)),$P(^(0),U,15)="" S $P(^(0),U,15)=12
- S $P(^OR(100,ORIFN,3),U,7)=ORDA D:$G(ORSTS) STATUS^ORCSAVE2(ORIFN,ORSTS)
- D PXRMKILL^ORDD100(ORIFN,ORVP,ORLOG) ; JEH 255
- D RELEASE^ORCSAVE2(ORIFN,ORDA,ORLOG,ORDUZ,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
- ; -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,8,ORDA,0),U,14)=ORDA
- K:OREASON="RESUBMIT" ^OR(100,ORIFN,6) ;clear previous DC data
- I OREASON="RESUBMIT" N DA S DA=+ORIFN D EK^ORDD100A S $P(^OR(100,ORIFN,0),U,9)="" ;p415 clear stop date/time including xref "AE"
- D PXRMADD^ORDD100(ORIFN,ORVP,ORLOG) ; JEH 255
- I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL)
- Q
- ;
- SN ; -- New backdoor order: return NA msg w/ORIFN, or DE msg
- N ORDIALOG,ORDG,ORP K ^TMP("ORWORD",$J) S:'$L(ORNATR) ORNATR="W"
- I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q
- I ORDUZ,'$D(^VA(200,ORDUZ,0)) S ORERR="Invalid entering person" Q
- I '$G(ORL) S ORERR="Missing or invalid patient location" Q
- D DLG Q:$D(ORERR) Q:'$D(ORDIALOG)
- SN1 D EN^ORCSAVE K ^TMP("ORWORD",$J) ; setting status, xrefs
- I '$G(ORIFN) S ORERR="Cannot create new order" Q
- ;Save DG1 and ZCL segments of HL7 message from backdoor orders
- D BDOSTR^ORWDBA3
- D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1)
- S:'ORSTRT ORSTRT=$$NOW^XLFDT D DATES^ORCSAVE2(+ORIFN,ORSTRT)
- D:$G(ORSTS) STATUS^ORCSAVE2(ORIFN,ORSTS)
- I $G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL) ; chart copy
- S ^OR(100,ORIFN,4)=PKGIFN
- Q
- ;
- DLG ; -- Build ORDIALOG(),ORDG from msg
- N OBR,USID,TYPE,OI,ZSV,J,OBX,WP,I,DSTID
- S OBR=$$OBR I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q
- S USID=$P(@ORMSG@(OBR),"|",5),TYPE=$S(USID["99CON":"CONSULT",1:"REQUEST")
- S ORDIALOG=$O(^ORD(101.41,"AB","GMRCOR "_TYPE,0))
- D GETDLG1^ORCD(ORDIALOG)
- S ORDIALOG($$PTR("URGENCY"),1)=ORURG
- ;ORSTRT & ORSTOP defined in routine ORM
- S ORDIALOG($$PTR("CLINICALLY INDICATED DATE"),1)=ORSTRT ;WAT/280/350
- S OI=$$ORDITEM^ORM(USID) I 'OI S ORERR="Invalid consult or procedure" Q
- S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI
- S ZSV=$O(@ORMSG@(OBR)) I ZSV,$E(@ORMSG@(ZSV),1,3)="ZSV" D
- . N X1,X2 S X1=$P(@ORMSG@(ZSV),"|",2),X2=$P(@ORMSG@(ZSV),"|",3)
- . I TYPE="REQUEST" S ORDIALOG($$PTR("REQUEST SERVICE"),1)=+$P(X1,U,4)
- . I TYPE="CONSULT",$L(X2) S ORDIALOG($$PTR("FREE TEXT OI"),1)=X2
- . S DSTID=$P(@ORMSG@(ZSV),"|",4) S:$L(DSTID) ORDIALOG($$PTR("DST ID"),1)=DSTID
- D1 S ORDIALOG($$PTR("CATEGORY"),1)=$G(ORCAT)
- S J=$P(@ORMSG@(OBR),"|",19),ORDIALOG($$PTR("PLACE OF CONSULTATION"),1)=$S(J="OC":"C",1:J)
- S ORDIALOG($$PTR("PROVIDER"),1)=$P(@ORMSG@(OBR),"|",20)
- S OBX=OBR F S OBX=$O(@ORMSG@(OBX)) Q:OBX'>0 S J=$E(@ORMSG@(OBX),1,3) Q:J="ORC" Q:J="MSH" I J="OBX" D
- . N SEG,NAME,VALUE S SEG=@ORMSG@(OBX)
- . S NAME=$$UP^XLFSTR($P($P(SEG,"|",4),U,2)),VALUE=$P(SEG,"|",6)
- . I NAME="PROVISIONAL DIAGNOSIS" D Q
- .. S:$P(SEG,"|",3)="CE" ORDIALOG($$PTR("CODE"),1)=$P(VALUE,U),VALUE=$P(VALUE,U,2)
- .. S ORDIALOG($$PTR("FREE TEXT"),1)=VALUE
- . S WP=$$PTR("WORD PROCESSING 1"),I=1,^TMP("ORWORD",$J,WP,1,I,0)=VALUE
- . S J=0 F S J=$O(@ORMSG@(OBX,J)) Q:J'>0 S I=I+1,^TMP("ORWORD",$J,WP,1,I,0)=@ORMSG@(OBX,J)
- S:$G(I) ^TMP("ORWORD",$J,WP,1,0)="^^"_I_U_I_U_DT_U,ORDIALOG(WP,1)="^TMP(""ORWORD"",$J,"_WP_",1)"
- Q
- ;
- OBR() ; -- Return subscript of RXE segment
- N X,I,SEG S X="",I=+ORC
- F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="OBR" S X=I Q
- Q X
- ;
- SC ; -- Status changed (i.e. scheduled)
- S:'$G(ORSTS) ORSTS=6 D STATUS^ORCSAVE2(+ORIFN,ORSTS) ; 6=active
- Q
- ;
- STATUS(X) ; -- Returns ptr to Order Status file #100.01
- Q $S(X="DC":1,X="CM":2,X="HD":3,X="IP":5,X="SC":6,X="A":9,X="RP":12,X="CA":13,X="ZC":8,1:5)
- ;
- RE ; -- Completed, w/results
- N I,SEG,DA,DR,DIE,X,Y
- S:'$G(ORSTS) ORSTS=2 D STATUS^ORCSAVE2(+ORIFN,ORSTS)
- S X="",DA=+ORIFN,DIE="^OR(100,"
- S DR="71////"_+$E($$NOW^XLFDT,1,12) D ^DIE
- S I=+ORC,X="" F S I=$O(@ORMSG@(I)) Q:I<1 S SEG=$G(@ORMSG@(I)) Q:$E(SEG,1,3)="ORC" I $E(SEG,1,3)="OBX",$P(SEG,"|",4)["SIG FINDINGS" S X=$P(SEG,"|",6) Q
- S $P(^OR(100,DA,7),U,2)=$S(X="Y":1,1:"")
- S:'$G(ORNP) ORNP=+$P($G(^OR(100,+ORIFN,0)),U,4)
- Q
- ;
- UA ; -- Unable to Accept [ack]
- S ORDUZ="" I '$L(OREASON1),$L(OREASON) S OREASON1=OREASON
- OC ; -- Cancelled/Denied
- S:'$L(ORNATR) ORNATR="X" ;Rejected
- S ^OR(100,+ORIFN,6)=$O(^ORD(100.02,"C",ORNATR,0))_U_ORDUZ_U_ORLOG_U_U_OREASON1
- D STATUS^ORCSAVE2(+ORIFN,13) I ORDCNTRL="OC" D UPDATE("DC") Q
- UD ; -- Unable to discontinue [ack]
- N DA S DA=$P(ORIFN,";",2) I DA D
- . S $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ;request rejected
- . S:$L(OREASON1) ^OR(100,+ORIFN,8,DA,1)=OREASON1
- Q
- ;
- OD ; -- Discontinued
- S ^OR(100,+ORIFN,6)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON1
- D STATUS^ORCSAVE2(+ORIFN,1),UPDATE("DC"):$L(ORNATR)
- Q
- ;
- DR ; -- Discontinued [ack]
- D STATUS^ORCSAVE2(+ORIFN,1)
- Q
- ;
- UPDATE(ORACT) ; -- continue processing
- N ORX,ORDA,ORP
- S ORX=$$CREATE^ORX1(ORNATR) D:ORX
- . S ORDA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON1,ORLOG,ORDUZ)
- . I ORDA'>0 S ORERR="Cannot create new order action" Q
- . D RELEASE^ORCSAVE2(+ORIFN,ORDA,ORLOG,ORDUZ,ORNATR)
- . D SIGSTS^ORCSAVE2(+ORIFN,ORDA)
- . I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL)
- . S $P(^OR(100,+ORIFN,3),U,7)=ORDA
- I 'ORX,ORACT="DC",'$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0
- D:$G(ORACT)="DC" CANCEL^ORCSEND(+ORIFN)
- Q
- ;
- PTR(X) ; -- Returns ptr to prompt in Order Dialog file #101.41
- Q $O(^ORD(101.41,"AB",$E("OR GTX "_X,1,63),0))
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORMGMRC 7693 printed Mar 13, 2025@21:36:55 Page 2
- ORMGMRC ; SLC/MKB - Process Consult ORM msgs ;Oct 27, 2023@12:13:26
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,26,68,92,153,174,195,255,243,280,350,415,519,535**;Dec 17, 1997;Build 20
- +2 ;Reference to ^VA(200 in ICR #4329
- +3 ;Reference to ^DIE in ICR #10018
- +4 ;Reference to $$NOW^XLFDT in ICR #10103
- +5 ;Reference to $$UP^XLFSTR in ICR #10104
- +6 ;
- EN ; -- entry point for GMRC messges
- +1 ;S ORERR="Invalid order control code" Q
- IF '$LENGTH($TEXT(@ORDCNTRL))
- QUIT
- +2 IF ORDCNTRL'="SN"
- IF ORDCNTRL'="ZP"
- IF 'ORIFN!('$DATA(^OR(100,+ORIFN,0)))
- SET ORERR="Invalid OE/RR order number"
- QUIT
- +3 ;new code
- if ORDCNTRL="OC"&(ORTYPE="ORR")
- SET ORDCNTRL="UA"
- +4 NEW ORSTS,OREASON1,NTE
- SET ORSTS=$$STATUS(ORDSTS)
- +5 if 'ORLOG
- SET ORLOG=$$NOW^XLFDT
- if 'ORDUZ
- SET ORDUZ=DUZ
- if $GET(DGPMT)
- SET ORDUZ=""
- +6 SET OREASON=$PIECE(OREASON,U,5)
- SET NTE=$ORDER(@ORMSG@(+ORC))
- SET OREASON1=""
- +7 IF NTE
- IF $EXTRACT(@ORMSG@(NTE),1,3)="NTE"
- SET OREASON1=$PIECE(@ORMSG@(NTE),"|",4)
- +8 DO @ORDCNTRL
- +9 QUIT
- +10 ;
- ZP ; -- Purged
- +1 if 'ORIFN
- QUIT
- if '$DATA(^OR(100,+ORIFN,0))
- QUIT
- +2 ; Remove pkg reference, sts=lapsed if still active
- KILL ^OR(100,+ORIFN,4)
- IF "^3^5^6^8^"[(U_$PIECE($GET(^(3)),U,3)_U)
- DO STATUS^ORCSAVE2(+ORIFN,14)
- +3 QUIT
- +4 ;
- ZR ; -- Purged as requested [ack]
- +1 DO DELETE^ORCSAVE2(+ORIFN)
- +2 QUIT
- +3 ;
- ZU ; -- Unable to purge [ack]
- +1 ; update Last Activity
- SET $PIECE(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT
- +2 QUIT
- +3 ;
- OK ; -- Order accepted, GMRC order # assigned [ack]
- +1 SET ^OR(100,+ORIFN,4)=PKGIFN
- if '$GET(ORSTS)
- SET ORSTS=5
- +2 ; 5=pending
- DO STATUS^ORCSAVE2(+ORIFN,ORSTS)
- +3 DO DATES^ORCSAVE2(+ORIFN,+$EXTRACT($$NOW^XLFDT,1,12))
- +4 QUIT
- +5 ;
- XX ; -- Change order
- +1 NEW ORDIALOG,ORDG,ORDA,ORX,ORP,ORSIG
- if '$LENGTH(ORNATR)
- SET ORNATR="S"
- +2 DO DLG
- if $DATA(ORERR)
- QUIT
- if '$DATA(ORDIALOG)
- QUIT
- SET ORIFN=+ORIFN
- +3 SET ORDA=$$ACTION^ORCSAVE("XX",ORIFN,ORNP,OREASON1,ORLOG,ORDUZ)
- +4 IF ORDA'>0
- SET ORERR="Cannot create new order action"
- QUIT
- +5 ; -Update sts of order to active, last action to dc/edit:
- +6 SET ORX=+$PIECE($GET(^OR(100,ORIFN,3)),U,7)
- if ORX'>0
- SET ORX=+$ORDER(^(8,ORDA),-1)
- +7 IF $DATA(^OR(100,ORIFN,8,ORX,0))
- IF $PIECE(^(0),U,15)=""
- SET $PIECE(^(0),U,15)=12
- +8 SET $PIECE(^OR(100,ORIFN,3),U,7)=ORDA
- if $GET(ORSTS)
- DO STATUS^ORCSAVE2(ORIFN,ORSTS)
- +9 ; JEH 255
- DO PXRMKILL^ORDD100(ORIFN,ORVP,ORLOG)
- +10 DO RELEASE^ORCSAVE2(ORIFN,ORDA,ORLOG,ORDUZ,ORNATR)
- +11 ; -If unsigned edit, leave XX unsigned & mark ORX as Sig Not Req'd
- +12 SET ORSIG=$SELECT($PIECE($GET(^OR(100,ORIFN,8,ORX,0)),U,4)'=2:1,1:0)
- +13 if ORSIG
- DO SIGSTS^ORCSAVE2(ORIFN,ORDA)
- if 'ORSIG
- DO SIGN^ORCSAVE2(ORIFN,,,5,ORX)
- +14 ; -Update responses, get/save new order text:
- +15 KILL ^OR(100,ORIFN,4.5)
- DO RESPONSE^ORCSAVE
- DO ORDTEXT^ORCSAVE1(ORIFN_";"_ORDA)
- +16 SET $PIECE(^OR(100,ORIFN,8,ORDA,0),U,14)=ORDA
- +17 ;clear previous DC data
- if OREASON="RESUBMIT"
- KILL ^OR(100,ORIFN,6)
- +18 ;p415 clear stop date/time including xref "AE"
- IF OREASON="RESUBMIT"
- NEW DA
- SET DA=+ORIFN
- DO EK^ORDD100A
- SET $PIECE(^OR(100,ORIFN,0),U,9)=""
- +19 ; JEH 255
- DO PXRMADD^ORDD100(ORIFN,ORVP,ORLOG)
- +20 IF $GET(ORL)
- SET ORP(1)=+ORIFN_";"_ORDA_"^1"
- DO PRINTS^ORWD1(.ORP,+ORL)
- +21 QUIT
- +22 ;
- SN ; -- New backdoor order: return NA msg w/ORIFN, or DE msg
- +1 NEW ORDIALOG,ORDG,ORP
- KILL ^TMP("ORWORD",$JOB)
- if '$LENGTH(ORNATR)
- SET ORNATR="W"
- +2 IF '$DATA(^VA(200,ORNP,0))
- SET ORERR="Missing or invalid ordering provider"
- QUIT
- +3 IF ORDUZ
- IF '$DATA(^VA(200,ORDUZ,0))
- SET ORERR="Invalid entering person"
- QUIT
- +4 IF '$GET(ORL)
- SET ORERR="Missing or invalid patient location"
- QUIT
- +5 DO DLG
- if $DATA(ORERR)
- QUIT
- if '$DATA(ORDIALOG)
- QUIT
- SN1 ; setting status, xrefs
- DO EN^ORCSAVE
- KILL ^TMP("ORWORD",$JOB)
- +1 IF '$GET(ORIFN)
- SET ORERR="Cannot create new order"
- QUIT
- +2 ;Save DG1 and ZCL segments of HL7 message from backdoor orders
- +3 DO BDOSTR^ORWDBA3
- +4 DO RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR)
- DO SIGSTS^ORCSAVE2(ORIFN,1)
- +5 if 'ORSTRT
- SET ORSTRT=$$NOW^XLFDT
- DO DATES^ORCSAVE2(+ORIFN,ORSTRT)
- +6 if $GET(ORSTS)
- DO STATUS^ORCSAVE2(ORIFN,ORSTS)
- +7 ; chart copy
- IF $GET(ORL)
- SET ORP(1)=ORIFN_";1^1"
- DO PRINTS^ORWD1(.ORP,+ORL)
- +8 SET ^OR(100,ORIFN,4)=PKGIFN
- +9 QUIT
- +10 ;
- DLG ; -- Build ORDIALOG(),ORDG from msg
- +1 NEW OBR,USID,TYPE,OI,ZSV,J,OBX,WP,I,DSTID
- +2 SET OBR=$$OBR
- IF 'OBR!($EXTRACT($GET(@ORMSG@(OBR)),1,3)'="OBR")
- SET ORERR="Missing OBR segment"
- QUIT
- +3 SET USID=$PIECE(@ORMSG@(OBR),"|",5)
- SET TYPE=$SELECT(USID["99CON":"CONSULT",1:"REQUEST")
- +4 SET ORDIALOG=$ORDER(^ORD(101.41,"AB","GMRCOR "_TYPE,0))
- +5 DO GETDLG1^ORCD(ORDIALOG)
- +6 SET ORDIALOG($$PTR("URGENCY"),1)=ORURG
- +7 ;ORSTRT & ORSTOP defined in routine ORM
- +8 ;WAT/280/350
- SET ORDIALOG($$PTR("CLINICALLY INDICATED DATE"),1)=ORSTRT
- +9 SET OI=$$ORDITEM^ORM(USID)
- IF 'OI
- SET ORERR="Invalid consult or procedure"
- QUIT
- +10 SET ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI
- +11 SET ZSV=$ORDER(@ORMSG@(OBR))
- IF ZSV
- IF $EXTRACT(@ORMSG@(ZSV),1,3)="ZSV"
- Begin DoDot:1
- +12 NEW X1,X2
- SET X1=$PIECE(@ORMSG@(ZSV),"|",2)
- SET X2=$PIECE(@ORMSG@(ZSV),"|",3)
- +13 IF TYPE="REQUEST"
- SET ORDIALOG($$PTR("REQUEST SERVICE"),1)=+$PIECE(X1,U,4)
- +14 IF TYPE="CONSULT"
- IF $LENGTH(X2)
- SET ORDIALOG($$PTR("FREE TEXT OI"),1)=X2
- +15 SET DSTID=$PIECE(@ORMSG@(ZSV),"|",4)
- if $LENGTH(DSTID)
- SET ORDIALOG($$PTR("DST ID"),1)=DSTID
- End DoDot:1
- D1 SET ORDIALOG($$PTR("CATEGORY"),1)=$GET(ORCAT)
- +1 SET J=$PIECE(@ORMSG@(OBR),"|",19)
- SET ORDIALOG($$PTR("PLACE OF CONSULTATION"),1)=$SELECT(J="OC":"C",1:J)
- +2 SET ORDIALOG($$PTR("PROVIDER"),1)=$PIECE(@ORMSG@(OBR),"|",20)
- +3 SET OBX=OBR
- FOR
- SET OBX=$ORDER(@ORMSG@(OBX))
- if OBX'>0
- QUIT
- SET J=$EXTRACT(@ORMSG@(OBX),1,3)
- if J="ORC"
- QUIT
- if J="MSH"
- QUIT
- IF J="OBX"
- Begin DoDot:1
- +4 NEW SEG,NAME,VALUE
- SET SEG=@ORMSG@(OBX)
- +5 SET NAME=$$UP^XLFSTR($PIECE($PIECE(SEG,"|",4),U,2))
- SET VALUE=$PIECE(SEG,"|",6)
- +6 IF NAME="PROVISIONAL DIAGNOSIS"
- Begin DoDot:2
- +7 if $PIECE(SEG,"|",3)="CE"
- SET ORDIALOG($$PTR("CODE"),1)=$PIECE(VALUE,U)
- SET VALUE=$PIECE(VALUE,U,2)
- +8 SET ORDIALOG($$PTR("FREE TEXT"),1)=VALUE
- End DoDot:2
- QUIT
- +9 SET WP=$$PTR("WORD PROCESSING 1")
- SET I=1
- SET ^TMP("ORWORD",$JOB,WP,1,I,0)=VALUE
- +10 SET J=0
- FOR
- SET J=$ORDER(@ORMSG@(OBX,J))
- if J'>0
- QUIT
- SET I=I+1
- SET ^TMP("ORWORD",$JOB,WP,1,I,0)=@ORMSG@(OBX,J)
- End DoDot:1
- +11 if $GET(I)
- SET ^TMP("ORWORD",$JOB,WP,1,0)="^^"_I_U_I_U_DT_U
- SET ORDIALOG(WP,1)="^TMP(""ORWORD"",$J,"_WP_",1)"
- +12 QUIT
- +13 ;
- OBR() ; -- Return subscript of RXE segment
- +1 NEW X,I,SEG
- SET X=""
- SET I=+ORC
- +2 FOR
- SET I=$ORDER(@ORMSG@(I))
- if I'>0
- QUIT
- SET SEG=$EXTRACT(@ORMSG@(I),1,3)
- if SEG="ORC"
- QUIT
- IF SEG="OBR"
- SET X=I
- QUIT
- +3 QUIT X
- +4 ;
- SC ; -- Status changed (i.e. scheduled)
- +1 ; 6=active
- if '$GET(ORSTS)
- SET ORSTS=6
- DO STATUS^ORCSAVE2(+ORIFN,ORSTS)
- +2 QUIT
- +3 ;
- STATUS(X) ; -- Returns ptr to Order Status file #100.01
- +1 QUIT $SELECT(X="DC":1,X="CM":2,X="HD":3,X="IP":5,X="SC":6,X="A":9,X="RP":12,X="CA":13,X="ZC":8,1:5)
- +2 ;
- RE ; -- Completed, w/results
- +1 NEW I,SEG,DA,DR,DIE,X,Y
- +2 if '$GET(ORSTS)
- SET ORSTS=2
- DO STATUS^ORCSAVE2(+ORIFN,ORSTS)
- +3 SET X=""
- SET DA=+ORIFN
- SET DIE="^OR(100,"
- +4 SET DR="71////"_+$EXTRACT($$NOW^XLFDT,1,12)
- DO ^DIE
- +5 SET I=+ORC
- SET X=""
- FOR
- SET I=$ORDER(@ORMSG@(I))
- if I<1
- QUIT
- SET SEG=$GET(@ORMSG@(I))
- if $EXTRACT(SEG,1,3)="ORC"
- QUIT
- IF $EXTRACT(SEG,1,3)="OBX"
- IF $PIECE(SEG,"|",4)["SIG FINDINGS"
- SET X=$PIECE(SEG,"|",6)
- QUIT
- +6 SET $PIECE(^OR(100,DA,7),U,2)=$SELECT(X="Y":1,1:"")
- +7 if '$GET(ORNP)
- SET ORNP=+$PIECE($GET(^OR(100,+ORIFN,0)),U,4)
- +8 QUIT
- +9 ;
- UA ; -- Unable to Accept [ack]
- +1 SET ORDUZ=""
- IF '$LENGTH(OREASON1)
- IF $LENGTH(OREASON)
- SET OREASON1=OREASON
- OC ; -- Cancelled/Denied
- +1 ;Rejected
- if '$LENGTH(ORNATR)
- SET ORNATR="X"
- +2 SET ^OR(100,+ORIFN,6)=$ORDER(^ORD(100.02,"C",ORNATR,0))_U_ORDUZ_U_ORLOG_U_U_OREASON1
- +3 DO STATUS^ORCSAVE2(+ORIFN,13)
- IF ORDCNTRL="OC"
- DO UPDATE("DC")
- QUIT
- UD ; -- Unable to discontinue [ack]
- +1 NEW DA
- SET DA=$PIECE(ORIFN,";",2)
- IF DA
- Begin DoDot:1
- +2 ;request rejected
- SET $PIECE(^OR(100,+ORIFN,8,DA,0),U,15)=13
- +3 if $LENGTH(OREASON1)
- SET ^OR(100,+ORIFN,8,DA,1)=OREASON1
- End DoDot:1
- +4 QUIT
- +5 ;
- OD ; -- Discontinued
- +1 SET ^OR(100,+ORIFN,6)=$SELECT($LENGTH(ORNATR):$ORDER(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON1
- +2 DO STATUS^ORCSAVE2(+ORIFN,1)
- if $LENGTH(ORNATR)
- DO UPDATE("DC")
- +3 QUIT
- +4 ;
- DR ; -- Discontinued [ack]
- +1 DO STATUS^ORCSAVE2(+ORIFN,1)
- +2 QUIT
- +3 ;
- UPDATE(ORACT) ; -- continue processing
- +1 NEW ORX,ORDA,ORP
- +2 SET ORX=$$CREATE^ORX1(ORNATR)
- if ORX
- Begin DoDot:1
- +3 SET ORDA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON1,ORLOG,ORDUZ)
- +4 IF ORDA'>0
- SET ORERR="Cannot create new order action"
- QUIT
- +5 DO RELEASE^ORCSAVE2(+ORIFN,ORDA,ORLOG,ORDUZ,ORNATR)
- +6 DO SIGSTS^ORCSAVE2(+ORIFN,ORDA)
- +7 IF $GET(ORL)
- SET ORP(1)=+ORIFN_";"_ORDA_"^1"
- DO PRINTS^ORWD1(.ORP,+ORL)
- +8 SET $PIECE(^OR(100,+ORIFN,3),U,7)=ORDA
- End DoDot:1
- +9 IF 'ORX
- IF ORACT="DC"
- IF '$$ACTV^ORX1(ORNATR)
- SET $PIECE(^OR(100,+ORIFN,3),U,7)=0
- +10 if $GET(ORACT)="DC"
- DO CANCEL^ORCSEND(+ORIFN)
- +11 QUIT
- +12 ;
- PTR(X) ; -- Returns ptr to prompt in Order Dialog file #101.41
- +1 QUIT $ORDER(^ORD(101.41,"AB",$EXTRACT("OR GTX "_X,1,63),0))
