- ORMFH ;SLC/MKB - Process Dietetics ORM msgs ;5/5/05 13:18
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,73,92,215,243**;Dec 17, 1997;Build 242
- ;
- EN ; -- entry point for FH messages
- 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 ORLOG=+$E($$NOW^XLFDT,1,12) S:'$G(ORDUZ) ORDUZ=DUZ S:'$G(ORNP) ORNP=ORDUZ
- S:$G(DGPMT) ORNATR="A",OREASON=$S(DGPMT=1:"Admission",DGPMT=3:"Discharge",1:"Transfer"),ORDUZ=""
- D @ORDCNTRL
- Q
- ;
- ZP ; -- Purged
- Q:'ORIFN Q:'$D(^OR(100,+ORIFN,0))
- K ^OR(100,+ORIFN,4) I "^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, FH order # assigned [ack]
- N ORSTS S ^OR(100,+ORIFN,4)=PKGIFN ; FH identifier
- I "DN"'[$E(PKGIFN) S ORSTS=6 ;not Diet or NPO
- E S ORSTS=$S($P($G(^OR(100,+ORIFN,0)),U,8)>ORLOG:8,1:6)
- D STATUS^ORCSAVE2(+ORIFN,ORSTS)
- Q
- ;
- XX ; -- Edited backdoor order (OP recurring meals only)
- D XX^ORMFH1 Q
- ;
- SN ; -- New backdoor order: return NA msg w/ORIFN
- N ODS,ODT,OBR,ORDIALOG,X,I,OI,SEG,ORNEW,ORPARAM,ORTIME,ORSTS,ORDG,ORP,ORTRAIL
- ;I '$D(^VA(200,+ORNP,0)) S ORERR="Missing or invalid ordering provider"Q
- ; Don't require provider until Nature of Order is added
- I '$G(DGPMT),'$D(^VA(200,+ORDUZ,0)) S ORERR="Missing or invalid entering person" Q
- I 'ORSTRT S ORERR="Missing effective date/time" Q
- ;I '$G(ORL) S ORERR="Missing or invalid patient location" Q
- D EN1^FHWOR8(ORL,.ORPARAM)
- S ODS=$O(@ORMSG@(+ORC)) I 'ODS S ORERR="Incomplete message" Q
- S ODS=ODS_U_@ORMSG@(ODS),ORSTS=6 I '$L(ORNATR),ORCAT="I" S ORNATR="S"
- I $E($P(ODS,U,2),1,3)="OBR" S OBR=ODS D IP G SN1
- I $E($P(ODS,U,2),1,3)="ODT" S ODT=ODS D TRAY G SN1
- I $E($P(ODS,U,2),1,3)'="ODS" S ORERR="Missing or invalid ODS segment" Q
- I $P(ODS,"|",2)="ZE" D TF G SN1
- I $P(ODS,"|",4)?1"^^^FH-6".E D ADDL G SN1
- I ORCAT'="I" D OPM^ORMFH1 G SN1
- I $P(ODS,"|",4)?1"^^^FH-5".E D NPO G SN1
- DIET ; Diet order
- S ORDIALOG=$O(^ORD(101.41,"AB","FHW1",0)),ORTRAIL="Diet"
- D GETDLG1^ORCD(ORDIALOG) S:ORSTRT>ORLOG ORSTS=8
- S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT
- S:ORSTOP ORDIALOG($$PTR("STOP DATE/TIME"),1)=ORSTOP
- S X=$P(ODS,"|",2),ORDIALOG($$PTR("DELIVERY"),1)=$S($L(X)=1:X,1:$E(X,2))
- ; Comments ??
- S X=$$ORDITEM^ORM($P(ODS,"|",4))
- I 'X S ORERR="Missing or invalid diet modification" Q
- S I=1,OI=$$PTR("ORDERABLE ITEM"),ORDIALOG(OI,I)=X
- I $O(@ORMSG@(+ODS)) F S ODS=$O(@ORMSG@(+ODS)) Q:ODS'>0 S SEG=$E(@ORMSG@(+ODS),1,3) Q:SEG="ORC" Q:SEG="MSH" I SEG="ODS" D Q:$D(ORERR)
- . S X=$$ORDITEM^ORM($P(@ORMSG@(+ODS),"|",4))
- . I 'X S ORERR="Missing or invalid diet modification" Q
- . S I=I+1,ORDIALOG(OI,I)=X
- SN1 ; continue ... save order, post message
- Q:$D(ORERR)
- D EN^ORCSAVE I '$G(ORIFN) S ORERR="Cannot create new order" Q
- D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1)
- D:'$P($G(^OR(100,ORIFN,0)),U,8) DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP)
- D 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
- ;
- TRAY ; Early/Late tray
- I 'ORSTOP S ORERR="Missing stop date" Q
- S ORDIALOG=$O(^ORD(101.41,"AB","FHW2",0)) D GETDLG1^ORCD(ORDIALOG),EN2^ORCDFH
- S ORDIALOG($$PTR("START DATE"),1)=ORSTRT
- S ORDIALOG($$PTR("STOP DATE"),1)=ORSTOP
- N DAYS,SCH S DAYS="",SCH=$P(ORQT,U,2)
- I $L(SCH),SCH'="ONCE" F I=1:1:$L(SCH,"~") S X=+$P($P(SCH,"~",I),"J",2),DAYS=DAYS_$E("MTWRFSX",X)
- S:$L(DAYS) ORDIALOG($$PTR("SCHEDULE"),1)=DAYS
- S OI=+$O(^ORD(101.43,"S.E/L T",$P(ODT,"|",2)_" TRAY",0)),ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI
- S X=$P($P(ODT,"|",3),U,4),ORDIALOG($$PTR("MEAL"),1)=$E(X)
- S ORDIALOG($$PTR("MEAL TIME"),1)=$P($G(ORTIME(OI,$E(X),+$E(X,3))),U,2)
- S:$L($P(ODT,"|",4)) ORDIALOG($$PTR("YES/NO"),1)=1
- Q
- ;
- IP ; Isolation/Precautions
- N IP S IP=+$P($P(OBR,"|",13),U,4)
- I IP'>0 S ORERR="Missing or invalid isolation type" Q
- S ORDIALOG=$O(^ORD(101.41,"AB","FHW3",0)) D GETDLG1^ORCD(ORDIALOG)
- S ORDIALOG($$PTR("ISOLATION TYPE"),1)=IP
- S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=$O(^ORD(101.43,"S.PREC","ISOLATION PROCEDURES",0))
- Q
- ;
- TF ; Tubefeeding
- N OI,STR,INSTR,CMMT,I,X,X4,XI,ZQT,QT,QTY,DUR
- S ORDIALOG=$O(^ORD(101.41,"AB","FHW8",0)) D GETDLG1^ORCD(ORDIALOG)
- S OI=$$PTR("ORDERABLE ITEM"),STR=$$PTR("STRENGTH FH")
- S INSTR=$$PTR("INSTRUCTIONS"),CMMT=$$PTR("FREE TEXT 1")
- ; Comments ??
- S I=0 F D S ODS=$O(@ORMSG@(+ODS)) Q:ODS'>0 Q:$E(@ORMSG@(ODS),1,3)="ORC" S ODS=ODS_U_@ORMSG@(ODS)
- . Q:$E($P(ODS,U,2),1,3)'="ODS" ; not ODS segment
- . S X=$P(ODS,"|",4),X4=$P(X,U,4) ; OI
- . S:X4["-" $P(X,U,4)=+X4,X4=+$P(X4,"-",2) ; strength
- . S XI=$$ORDITEM^ORM(X) I 'XI S ORERR="Missing or invalid tubefeeding product" Q
- . S ZQT=$O(@ORMSG@(+ODS)) I 'ZQT S ORERR="Missing QT information" Q
- . S QT=$P(@ORMSG@(ZQT),"|",3),DUR=$P(QT,U,3)
- . S QTY=+QT_" "_$$UNITS($P($P(QT,U),"&",2))_"/"_$P(QT,U,2)
- . S:$L(DUR) QTY=QTY_" X "_+$E(DUR,2,99)_$S($E(DUR)="H":"HR",1:"")
- . S I=I+1,ORDIALOG(OI,I)=XI,ORDIALOG(STR,I)=X4,ORDIALOG(INSTR,I)=QTY
- . S:$L($P(ODS,"|",5)) ORDIALOG(CMMT,I)=$P(ODS,"|",5)
- I ORCAT="O",ORQT["~" D DATES
- Q
- ;
- UNITS(X) ; -- Returns name of unit X
- N Y S X=$E(X)
- S Y=$S(X="K":"KCAL",X="C":"CC",X="M":"ML",X="O":"OZ",X="U":"UNITS",X="T":"TBSP",X="G":"GM",1:"")
- Q Y
- ;
- NPO ; NPO <uses FHW1 dialog - FHW4 now a quick order>
- S ORDIALOG=$O(^ORD(101.41,"AB","FHW1",0)) D GETDLG1^ORCD(ORDIALOG)
- S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=$O(^ORD(101.43,"S.DIET","NPO",0))
- S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT S:ORSTRT>ORLOG ORSTS=8
- S:ORSTOP ORDIALOG($$PTR("STOP DATE/TIME"),1)=ORSTOP
- S:$L($P(ODS,"|",5)) ORDIALOG($$PTR("FREE TEXT 1"),1)=$P(ODS,"|",5)
- Q
- ;
- ADDL ; Additional order
- S ORDIALOG=$O(^ORD(101.41,"AB","FHW7",0)) D GETDLG1^ORCD(ORDIALOG)
- S ORDIALOG($$PTR("FREE TEXT 1"),1)=$P(ODS,"|",5)
- I ORCAT="O",ORQT["~" D DATES
- Q
- ;
- DATES ; -- pull dates out of ORQT
- N P,I,X S P=$$PTR("DATE/TIME")
- F I=1:1:$L(ORQT,"~") S X=$P(ORQT,"~",I),ORDIALOG(P,I)=$$HL7TFM^XLFDT($P(X,U,4))
- S ORSTRT=$G(ORDIALOG(P,1)),ORSTOP=$G(ORDIALOG(P,I))
- Q
- ;
- SC ; -- Status Change
- SR ; -- Status Update [ack]
- N ORSTS,OROLD S OROLD=$P($G(^OR(100,+ORIFN,3)),U,3)
- D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
- S ORSTS=$S(ORDSTS="DC":1,ORDSTS="IP":6,ORDSTS="ZE":7,ORDSTS="SC":8,1:"")
- D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS)
- I ORDSTS="DC",'$D(^OR(100,+ORIFN,6)) D ;set 6-node
- . I ORNATR'="A","DN"[$E(PKGIFN) S ORNATR="C" S:'$L(OREASON) OREASON="Replaced with new diet order" S:ORDUZ<1 ORDUZ=""
- . S ^OR(100,+ORIFN,6)=$S($L(ORNATR):+$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON
- I OROLD=1,ORSTS=6 D ; reactivate
- . N X S $P(^OR(100,+ORIFN,3),U,7)=1,X=$P(^(0),U,9) K ^(6)
- . I 'ORSTOP,X S $P(^OR(100,+ORIFN,0),U,9)="" K ^OR(100,"AE",X,+ORIFN)
- . D SETALL^ORDD100(+ORIFN)
- Q
- ;
- OC ; -- Cancelled <E/L Trays only> / [ack]
- G:ORTYPE="ORR" UA ;rejected new order
- I $P($G(^OR(100,+ORIFN,3)),U,3)=6,$P(^(0),U,8)<ORLOG G OD
- S ^OR(100,+ORIFN,6)=$S($L(ORNATR):+$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON
- D UPDATE(13,"DC")
- Q
- ;
- CR ; -- Cancelled as requested [ack]
- D STATUS^ORCSAVE2(+ORIFN,13)
- Q
- ;
- OD ; -- Discontinued <Tubefeedings only>
- S ^OR(100,+ORIFN,6)=$S($L(ORNATR):+$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON
- D UPDATE(1,"DC")
- Q
- ;
- DR ; -- Discontinued as requested [ack]
- D STATUS^ORCSAVE2(+ORIFN,1)
- Q
- ;
- UA ; -- Unable to Accept [ack]
- S:'$L(ORNATR) ORNATR="X" ;Rejected
- S ^OR(100,+ORIFN,6)=+$O(^ORD(100.02,"C",ORNATR,0))_U_U_ORLOG_U_U_OREASON
- D STATUS^ORCSAVE2(+ORIFN,13)
- UC ; -- Unable to Cancel [ack]
- UD ; -- Unable to Discontinue [ack]
- N DA S DA=$P(ORIFN,";",2) I DA D
- . S:$G(OREJECT) $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ; request rejected
- . S:$L(OREASON) ^OR(100,+ORIFN,8,DA,1)=OREASON
- Q
- ;
- UPDATE(ORSTS,ORACT) ; -- continue processing
- N ORX,DA,ORP D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
- D:$G(ORSTS) STATUS^ORCSAVE2(+ORIFN,ORSTS)
- S ORX=$$CREATE^ORX1(ORNATR) D:ORX
- . S DA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON,ORLOG,ORDUZ)
- . I DA'>0 S ORERR="Cannot create new order action" Q
- . D RELEASE^ORCSAVE2(+ORIFN,DA,ORLOG,ORDUZ,ORNATR)
- . D SIGSTS^ORCSAVE2(+ORIFN,DA)
- . I $G(ORL) S ORP(1)=+ORIFN_";"_DA_"^1" D PRINTS^ORWD1(.ORP,+ORL)
- . S $P(^OR(100,+ORIFN,3),U,7)=DA
- I ORACT="DC",'$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0
- D:ORACT="DC" CANCEL^ORCSEND(+ORIFN)
- Q
- ;
- PTR(NAME) ; -- Returns ien of prompt NAME in Order Dialog file #101.41
- Q $O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0))
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORMFH 8841 printed Mar 13, 2025@21:36:52 Page 2
- ORMFH ;SLC/MKB - Process Dietetics ORM msgs ;5/5/05 13:18
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,73,92,215,243**;Dec 17, 1997;Build 242
- +2 ;
- EN ; -- entry point for FH messages
- +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 SET ORLOG=+$EXTRACT($$NOW^XLFDT,1,12)
- if '$GET(ORDUZ)
- SET ORDUZ=DUZ
- if '$GET(ORNP)
- SET ORNP=ORDUZ
- +4 if $GET(DGPMT)
- SET ORNATR="A"
- SET OREASON=$SELECT(DGPMT=1:"Admission",DGPMT=3:"Discharge",1:"Transfer")
- SET ORDUZ=""
- +5 DO @ORDCNTRL
- +6 QUIT
- +7 ;
- 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 "^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, FH order # assigned [ack]
- +1 ; FH identifier
- NEW ORSTS
- SET ^OR(100,+ORIFN,4)=PKGIFN
- +2 ;not Diet or NPO
- IF "DN"'[$EXTRACT(PKGIFN)
- SET ORSTS=6
- +3 IF '$TEST
- SET ORSTS=$SELECT($PIECE($GET(^OR(100,+ORIFN,0)),U,8)>ORLOG:8,1:6)
- +4 DO STATUS^ORCSAVE2(+ORIFN,ORSTS)
- +5 QUIT
- +6 ;
- XX ; -- Edited backdoor order (OP recurring meals only)
- +1 DO XX^ORMFH1
- QUIT
- +2 ;
- SN ; -- New backdoor order: return NA msg w/ORIFN
- +1 NEW ODS,ODT,OBR,ORDIALOG,X,I,OI,SEG,ORNEW,ORPARAM,ORTIME,ORSTS,ORDG,ORP,ORTRAIL
- +2 ;I '$D(^VA(200,+ORNP,0)) S ORERR="Missing or invalid ordering provider"Q
- +3 ; Don't require provider until Nature of Order is added
- +4 IF '$GET(DGPMT)
- IF '$DATA(^VA(200,+ORDUZ,0))
- SET ORERR="Missing or invalid entering person"
- QUIT
- +5 IF 'ORSTRT
- SET ORERR="Missing effective date/time"
- QUIT
- +6 ;I '$G(ORL) S ORERR="Missing or invalid patient location" Q
- +7 DO EN1^FHWOR8(ORL,.ORPARAM)
- +8 SET ODS=$ORDER(@ORMSG@(+ORC))
- IF 'ODS
- SET ORERR="Incomplete message"
- QUIT
- +9 SET ODS=ODS_U_@ORMSG@(ODS)
- SET ORSTS=6
- IF '$LENGTH(ORNATR)
- IF ORCAT="I"
- SET ORNATR="S"
- +10 IF $EXTRACT($PIECE(ODS,U,2),1,3)="OBR"
- SET OBR=ODS
- DO IP
- GOTO SN1
- +11 IF $EXTRACT($PIECE(ODS,U,2),1,3)="ODT"
- SET ODT=ODS
- DO TRAY
- GOTO SN1
- +12 IF $EXTRACT($PIECE(ODS,U,2),1,3)'="ODS"
- SET ORERR="Missing or invalid ODS segment"
- QUIT
- +13 IF $PIECE(ODS,"|",2)="ZE"
- DO TF
- GOTO SN1
- +14 IF $PIECE(ODS,"|",4)?1"^^^FH-6".E
- DO ADDL
- GOTO SN1
- +15 IF ORCAT'="I"
- DO OPM^ORMFH1
- GOTO SN1
- +16 IF $PIECE(ODS,"|",4)?1"^^^FH-5".E
- DO NPO
- GOTO SN1
- DIET ; Diet order
- +1 SET ORDIALOG=$ORDER(^ORD(101.41,"AB","FHW1",0))
- SET ORTRAIL="Diet"
- +2 DO GETDLG1^ORCD(ORDIALOG)
- if ORSTRT>ORLOG
- SET ORSTS=8
- +3 SET ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT
- +4 if ORSTOP
- SET ORDIALOG($$PTR("STOP DATE/TIME"),1)=ORSTOP
- +5 SET X=$PIECE(ODS,"|",2)
- SET ORDIALOG($$PTR("DELIVERY"),1)=$SELECT($LENGTH(X)=1:X,1:$EXTRACT(X,2))
- +6 ; Comments ??
- +7 SET X=$$ORDITEM^ORM($PIECE(ODS,"|",4))
- +8 IF 'X
- SET ORERR="Missing or invalid diet modification"
- QUIT
- +9 SET I=1
- SET OI=$$PTR("ORDERABLE ITEM")
- SET ORDIALOG(OI,I)=X
- +10 IF $ORDER(@ORMSG@(+ODS))
- FOR
- SET ODS=$ORDER(@ORMSG@(+ODS))
- if ODS'>0
- QUIT
- SET SEG=$EXTRACT(@ORMSG@(+ODS),1,3)
- if SEG="ORC"
- QUIT
- if SEG="MSH"
- QUIT
- IF SEG="ODS"
- Begin DoDot:1
- +11 SET X=$$ORDITEM^ORM($PIECE(@ORMSG@(+ODS),"|",4))
- +12 IF 'X
- SET ORERR="Missing or invalid diet modification"
- QUIT
- +13 SET I=I+1
- SET ORDIALOG(OI,I)=X
- End DoDot:1
- if $DATA(ORERR)
- QUIT
- SN1 ; continue ... save order, post message
- +1 if $DATA(ORERR)
- QUIT
- +2 DO EN^ORCSAVE
- IF '$GET(ORIFN)
- SET ORERR="Cannot create new order"
- QUIT
- +3 DO RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR)
- DO SIGSTS^ORCSAVE2(ORIFN,1)
- +4 if '$PIECE($GET(^OR(100,ORIFN,0)),U,8)
- DO DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP)
- +5 DO STATUS^ORCSAVE2(ORIFN,ORSTS)
- +6 ; chart copy
- IF $GET(ORL)
- SET ORP(1)=ORIFN_";1^1"
- DO PRINTS^ORWD1(.ORP,+ORL)
- +7 SET ^OR(100,ORIFN,4)=PKGIFN
- +8 QUIT
- +9 ;
- TRAY ; Early/Late tray
- +1 IF 'ORSTOP
- SET ORERR="Missing stop date"
- QUIT
- +2 SET ORDIALOG=$ORDER(^ORD(101.41,"AB","FHW2",0))
- DO GETDLG1^ORCD(ORDIALOG)
- DO EN2^ORCDFH
- +3 SET ORDIALOG($$PTR("START DATE"),1)=ORSTRT
- +4 SET ORDIALOG($$PTR("STOP DATE"),1)=ORSTOP
- +5 NEW DAYS,SCH
- SET DAYS=""
- SET SCH=$PIECE(ORQT,U,2)
- +6 IF $LENGTH(SCH)
- IF SCH'="ONCE"
- FOR I=1:1:$LENGTH(SCH,"~")
- SET X=+$PIECE($PIECE(SCH,"~",I),"J",2)
- SET DAYS=DAYS_$EXTRACT("MTWRFSX",X)
- +7 if $LENGTH(DAYS)
- SET ORDIALOG($$PTR("SCHEDULE"),1)=DAYS
- +8 SET OI=+$ORDER(^ORD(101.43,"S.E/L T",$PIECE(ODT,"|",2)_" TRAY",0))
- SET ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI
- +9 SET X=$PIECE($PIECE(ODT,"|",3),U,4)
- SET ORDIALOG($$PTR("MEAL"),1)=$EXTRACT(X)
- +10 SET ORDIALOG($$PTR("MEAL TIME"),1)=$PIECE($GET(ORTIME(OI,$EXTRACT(X),+$EXTRACT(X,3))),U,2)
- +11 if $LENGTH($PIECE(ODT,"|",4))
- SET ORDIALOG($$PTR("YES/NO"),1)=1
- +12 QUIT
- +13 ;
- IP ; Isolation/Precautions
- +1 NEW IP
- SET IP=+$PIECE($PIECE(OBR,"|",13),U,4)
- +2 IF IP'>0
- SET ORERR="Missing or invalid isolation type"
- QUIT
- +3 SET ORDIALOG=$ORDER(^ORD(101.41,"AB","FHW3",0))
- DO GETDLG1^ORCD(ORDIALOG)
- +4 SET ORDIALOG($$PTR("ISOLATION TYPE"),1)=IP
- +5 SET ORDIALOG($$PTR("ORDERABLE ITEM"),1)=$ORDER(^ORD(101.43,"S.PREC","ISOLATION PROCEDURES",0))
- +6 QUIT
- +7 ;
- TF ; Tubefeeding
- +1 NEW OI,STR,INSTR,CMMT,I,X,X4,XI,ZQT,QT,QTY,DUR
- +2 SET ORDIALOG=$ORDER(^ORD(101.41,"AB","FHW8",0))
- DO GETDLG1^ORCD(ORDIALOG)
- +3 SET OI=$$PTR("ORDERABLE ITEM")
- SET STR=$$PTR("STRENGTH FH")
- +4 SET INSTR=$$PTR("INSTRUCTIONS")
- SET CMMT=$$PTR("FREE TEXT 1")
- +5 ; Comments ??
- +6 SET I=0
- FOR
- Begin DoDot:1
- +7 ; not ODS segment
- if $EXTRACT($PIECE(ODS,U,2),1,3)'="ODS"
- QUIT
- +8 ; OI
- SET X=$PIECE(ODS,"|",4)
- SET X4=$PIECE(X,U,4)
- +9 ; strength
- if X4["-"
- SET $PIECE(X,U,4)=+X4
- SET X4=+$PIECE(X4,"-",2)
- +10 SET XI=$$ORDITEM^ORM(X)
- IF 'XI
- SET ORERR="Missing or invalid tubefeeding product"
- QUIT
- +11 SET ZQT=$ORDER(@ORMSG@(+ODS))
- IF 'ZQT
- SET ORERR="Missing QT information"
- QUIT
- +12 SET QT=$PIECE(@ORMSG@(ZQT),"|",3)
- SET DUR=$PIECE(QT,U,3)
- +13 SET QTY=+QT_" "_$$UNITS($PIECE($PIECE(QT,U),"&",2))_"/"_$PIECE(QT,U,2)
- +14 if $LENGTH(DUR)
- SET QTY=QTY_" X "_+$EXTRACT(DUR,2,99)_$SELECT($EXTRACT(DUR)="H":"HR",1:"")
- +15 SET I=I+1
- SET ORDIALOG(OI,I)=XI
- SET ORDIALOG(STR,I)=X4
- SET ORDIALOG(INSTR,I)=QTY
- +16 if $LENGTH($PIECE(ODS,"|",5))
- SET ORDIALOG(CMMT,I)=$PIECE(ODS,"|",5)
- End DoDot:1
- SET ODS=$ORDER(@ORMSG@(+ODS))
- if ODS'>0
- QUIT
- if $EXTRACT(@ORMSG@(ODS),1,3)="ORC"
- QUIT
- SET ODS=ODS_U_@ORMSG@(ODS)
- +17 IF ORCAT="O"
- IF ORQT["~"
- DO DATES
- +18 QUIT
- +19 ;
- UNITS(X) ; -- Returns name of unit X
- +1 NEW Y
- SET X=$EXTRACT(X)
- +2 SET Y=$SELECT(X="K":"KCAL",X="C":"CC",X="M":"ML",X="O":"OZ",X="U":"UNITS",X="T":"TBSP",X="G":"GM",1:"")
- +3 QUIT Y
- +4 ;
- NPO ; NPO <uses FHW1 dialog - FHW4 now a quick order>
- +1 SET ORDIALOG=$ORDER(^ORD(101.41,"AB","FHW1",0))
- DO GETDLG1^ORCD(ORDIALOG)
- +2 SET ORDIALOG($$PTR("ORDERABLE ITEM"),1)=$ORDER(^ORD(101.43,"S.DIET","NPO",0))
- +3 SET ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT
- if ORSTRT>ORLOG
- SET ORSTS=8
- +4 if ORSTOP
- SET ORDIALOG($$PTR("STOP DATE/TIME"),1)=ORSTOP
- +5 if $LENGTH($PIECE(ODS,"|",5))
- SET ORDIALOG($$PTR("FREE TEXT 1"),1)=$PIECE(ODS,"|",5)
- +6 QUIT
- +7 ;
- ADDL ; Additional order
- +1 SET ORDIALOG=$ORDER(^ORD(101.41,"AB","FHW7",0))
- DO GETDLG1^ORCD(ORDIALOG)
- +2 SET ORDIALOG($$PTR("FREE TEXT 1"),1)=$PIECE(ODS,"|",5)
- +3 IF ORCAT="O"
- IF ORQT["~"
- DO DATES
- +4 QUIT
- +5 ;
- DATES ; -- pull dates out of ORQT
- +1 NEW P,I,X
- SET P=$$PTR("DATE/TIME")
- +2 FOR I=1:1:$LENGTH(ORQT,"~")
- SET X=$PIECE(ORQT,"~",I)
- SET ORDIALOG(P,I)=$$HL7TFM^XLFDT($PIECE(X,U,4))
- +3 SET ORSTRT=$GET(ORDIALOG(P,1))
- SET ORSTOP=$GET(ORDIALOG(P,I))
- +4 QUIT
- +5 ;
- SC ; -- Status Change
- SR ; -- Status Update [ack]
- +1 NEW ORSTS,OROLD
- SET OROLD=$PIECE($GET(^OR(100,+ORIFN,3)),U,3)
- +2 DO DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
- +3 SET ORSTS=$SELECT(ORDSTS="DC":1,ORDSTS="IP":6,ORDSTS="ZE":7,ORDSTS="SC":8,1:"")
- +4 if ORSTS
- DO STATUS^ORCSAVE2(+ORIFN,ORSTS)
- +5 ;set 6-node
- IF ORDSTS="DC"
- IF '$DATA(^OR(100,+ORIFN,6))
- Begin DoDot:1
- +6 IF ORNATR'="A"
- IF "DN"[$EXTRACT(PKGIFN)
- SET ORNATR="C"
- if '$LENGTH(OREASON)
- SET OREASON="Replaced with new diet order"
- if ORDUZ<1
- SET ORDUZ=""
- +7 SET ^OR(100,+ORIFN,6)=$SELECT($LENGTH(ORNATR):+$ORDER(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON
- End DoDot:1
- +8 ; reactivate
- IF OROLD=1
- IF ORSTS=6
- Begin DoDot:1
- +9 NEW X
- SET $PIECE(^OR(100,+ORIFN,3),U,7)=1
- SET X=$PIECE(^(0),U,9)
- KILL ^(6)
- +10 IF 'ORSTOP
- IF X
- SET $PIECE(^OR(100,+ORIFN,0),U,9)=""
- KILL ^OR(100,"AE",X,+ORIFN)
- +11 DO SETALL^ORDD100(+ORIFN)
- End DoDot:1
- +12 QUIT
- +13 ;
- OC ; -- Cancelled <E/L Trays only> / [ack]
- +1 ;rejected new order
- if ORTYPE="ORR"
- GOTO UA
- +2 IF $PIECE($GET(^OR(100,+ORIFN,3)),U,3)=6
- IF $PIECE(^(0),U,8)<ORLOG
- GOTO OD
- +3 SET ^OR(100,+ORIFN,6)=$SELECT($LENGTH(ORNATR):+$ORDER(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON
- +4 DO UPDATE(13,"DC")
- +5 QUIT
- +6 ;
- CR ; -- Cancelled as requested [ack]
- +1 DO STATUS^ORCSAVE2(+ORIFN,13)
- +2 QUIT
- +3 ;
- OD ; -- Discontinued <Tubefeedings only>
- +1 SET ^OR(100,+ORIFN,6)=$SELECT($LENGTH(ORNATR):+$ORDER(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON
- +2 DO UPDATE(1,"DC")
- +3 QUIT
- +4 ;
- DR ; -- Discontinued as requested [ack]
- +1 DO STATUS^ORCSAVE2(+ORIFN,1)
- +2 QUIT
- +3 ;
- UA ; -- Unable to Accept [ack]
- +1 ;Rejected
- if '$LENGTH(ORNATR)
- SET ORNATR="X"
- +2 SET ^OR(100,+ORIFN,6)=+$ORDER(^ORD(100.02,"C",ORNATR,0))_U_U_ORLOG_U_U_OREASON
- +3 DO STATUS^ORCSAVE2(+ORIFN,13)
- UC ; -- Unable to Cancel [ack]
- UD ; -- Unable to Discontinue [ack]
- +1 NEW DA
- SET DA=$PIECE(ORIFN,";",2)
- IF DA
- Begin DoDot:1
- +2 ; request rejected
- if $GET(OREJECT)
- SET $PIECE(^OR(100,+ORIFN,8,DA,0),U,15)=13
- +3 if $LENGTH(OREASON)
- SET ^OR(100,+ORIFN,8,DA,1)=OREASON
- End DoDot:1
- +4 QUIT
- +5 ;
- UPDATE(ORSTS,ORACT) ; -- continue processing
- +1 NEW ORX,DA,ORP
- DO DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
- +2 if $GET(ORSTS)
- DO STATUS^ORCSAVE2(+ORIFN,ORSTS)
- +3 SET ORX=$$CREATE^ORX1(ORNATR)
- if ORX
- Begin DoDot:1
- +4 SET DA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON,ORLOG,ORDUZ)
- +5 IF DA'>0
- SET ORERR="Cannot create new order action"
- QUIT
- +6 DO RELEASE^ORCSAVE2(+ORIFN,DA,ORLOG,ORDUZ,ORNATR)
- +7 DO SIGSTS^ORCSAVE2(+ORIFN,DA)
- +8 IF $GET(ORL)
- SET ORP(1)=+ORIFN_";"_DA_"^1"
- DO PRINTS^ORWD1(.ORP,+ORL)
- +9 SET $PIECE(^OR(100,+ORIFN,3),U,7)=DA
- End DoDot:1
- +10 IF ORACT="DC"
- IF '$$ACTV^ORX1(ORNATR)
- SET $PIECE(^OR(100,+ORIFN,3),U,7)=0
- +11 if ORACT="DC"
- DO CANCEL^ORCSEND(+ORIFN)
- +12 QUIT
- +13 ;
- PTR(NAME) ; -- Returns ien of prompt NAME in Order Dialog file #101.41
- +1 QUIT $ORDER(^ORD(101.41,"AB",$EXTRACT("OR GTX "_NAME,1,63),0))
