- ORWDX1 ; SLC/KCM/REV - Utilities for Order Dialogs ;06/20/17 07:41
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,187,195,215,243,296,341,350,461**;Dec 17, 1997;Build 8
- ;
- ;
- ;
- ;Reference to ^PSSORUTE supported by ICR #4555
- ;Reference to ^SC( supported by ICR #10040
- ;Reference to ^DIC(42 supported by ICR #10039
- ;Reference to ^DPT( supported by ICR #10035
- ;
- WRLST(LST,LOC) ; Return list of dialogs for writing orders
- ; .Y(n): DlgName^ListBox Text
- WRLST1 N ANENT
- S LOC=+$G(LOC)_";SC(" I 'LOC S LOC=""
- S ANENT="ALL^"_LOC_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+$G(^(5)),1:"")
- D WRLSTB(.LST) Q:$D(LST)>1 ; check ORWDX WRITE ORDERS first
- N ORX,X0,X5,ORERR,I,SEQ,IEN,DGRP,FID,TXT,TYP
- D GETLST^XPAR(.ORX,ANENT,"ORWOR WRITE ORDERS LIST","Q",.ORERR) Q:ORERR
- S I=0 F S I=$O(ORX(I)) Q:'I D
- . S SEQ=+ORX(I),IEN=$P(ORX(I),U,2),X0=$G(^ORD(101.41,+IEN,0)),X5=$G(^(5))
- . S DGRP=+$P(X0,U,5),FID=+$P(X5,U,5),TXT=$P(X5,U,4),TYP=$P(X0,U,4)
- . S:'$L(TXT) TXT=$P(X0,U,2)
- . I $P(X0,U,4)="M" S:'FID FID=1001
- . S LST(SEQ)=IEN_";"_FID_";"_DGRP_";"_TYP_U_TXT
- Q
- WRLSTB(LST) ; return menu from which Write Orders list is built
- N MNU,SEQ,IEN,ITM,TXT,FID,DGRP,X,TYP
- S MNU=$$GET^XPAR(ANENT,"ORWDX WRITE ORDERS LIST",1,"I") Q:'MNU
- S SEQ=0 F S SEQ=$O(^ORD(101.41,MNU,10,"B",SEQ)) Q:'SEQ D
- . S IEN=0 F S IEN=$O(^ORD(101.41,MNU,10,"B",SEQ,IEN)) Q:'IEN D
- . . S X=$G(^ORD(101.41,MNU,10,IEN,0)),ITM=+$P(X,U,2),TXT=$P(X,U,4)
- . . S X=$G(^ORD(101.41,ITM,5)),FID=+$P(X,U,5)
- . . S X=$G(^ORD(101.41,ITM,0)),TYP=$P(X,U,4),DGRP=+$P(X,U,5)
- . . S:'$L(TXT) TXT=$P(X,U,2)
- . . I TYP="M" S:'FID FID=1001
- . . S LST(SEQ)=ITM_";"_FID_";"_DGRP_";"_TYP_U_TXT
- Q
- DELPI ; delete PI from ORDIALOG if PI = ""
- ;Called from SAVE^ORWDX
- N ORPI S ORPI=0
- S ORPI=$O(^ORD(101.41,"B","OR GTX PATIENT INSTRUCTIONS",ORPI))
- Q:'$D(ORDIALOG(ORPI)) ;ORDIALOG is passed into SAVE^ORWDX which calls this section
- I '$D(ORDIALOG(ORPI,1)) K ORDIALOG(ORPI),ORDIALOG("WP",ORPI) Q
- N PINODE,PITX
- S PITX="",PINODE=$G(ORDIALOG(ORPI,1))
- S PITX=$G(@PINODE@(1,0))
- S PITX=$TR(PITX," ","")
- I '$L(PITX) K ORDIALOG(ORPI),ORDIALOG("WP",ORPI) Q
- N ORSIG S ORSIG=+$O(^ORD(101.41,"B","OR GTX SIG",0))
- I $$STR^ORWDXR(ORSIG)[$$STR^ORWDXR(ORPI) S ORDIALOG(ORPI,"FORMAT")="@"
- Q
- FNDINFO(Y,ODIEN) ;
- N ODI,CRTM,FRM,XX
- S FRM="",CRTM=$$NOW^XLFDT
- F S FRM=$O(^ORD(101.43,XRF,FRM)) Q:FRM="" D
- . S ODI=0 F S ODI=$O(^ORD(101.43,XRF,FRM,ODI)) Q:'ODI D
- .. S XX=^ORD(101.43,XRF,FRM,ODI) ;XRF NEW'd in ORWDX which calls this section
- .. I +$P(XX,U,3),$P(XX,U,3)<CRTM Q
- .. I ODI=ODIEN D
- ... S NM=NM+1 ;variable NEW'd in ORWDX which calls this section
- ... I 'XX S Y(NM)=ODIEN_U_$P(XX,U,2)_U_$P(XX,U,2)
- ... E S Y(NM)=ODIEN_U_$P(XX,U,2)_$C(9)_"<"_$P(XX,U,4)_">"_U_$P(XX,U,4)
- Q
- DLGDEF(LST,DLG) ; Format mapping for a dlg
- N I,IEN,ILST,X0,X2,XW S ILST=0
- I $O(^ORD(101.41,"AB",DLG,0))>0 S DLG=$O(^ORD(101.41,"AB",DLG,0))
- E S DLG=$O(^ORD(101.41,"B",DLG,0))
- Q:'DLG
- S I=0 F S I=$O(^ORD(101.41,DLG,10,I)) Q:I'>0 D
- . S X0=$G(^ORD(101.41,DLG,10,I,0)),X2=$G(^(2)),IEN=+$P(X0,U,2)
- . S ILST=ILST+1,LST(ILST)=U_IEN_U_$P(X2,U,1,7)
- . I $P(X0,U,11) S $P(LST(ILST),U,11)=1
- . S $P(LST(ILST),U)=$P($G(^ORD(101.41,IEN,1)),U,3)
- . I $P($G(^ORD(101.41,IEN,0)),U)="OR GTX ADDITIVE" S $P(LST(ILST),U)="ADDITIVE"
- . I $P($G(^ORD(101.41,IEN,0)),U)="OR GTX ADDL DIETS" S $P(LST(ILST),U)="ADDLDIETS"
- . I $L($P(LST(ILST),U))=0 S $P(LST(ILST),U)="ID"_IEN
- . I $D(^ORD(101.41,DLG,10,"DAD",IEN)) D
- .. N SEQ,DA,CHILD S CHILD=""
- .. S SEQ=0 F S SEQ=$O(^ORD(101.41,DLG,10,"DAD",IEN,SEQ)) Q:'SEQ D
- ... S DA=0 F S DA=$O(^ORD(101.41,DLG,10,"DAD",IEN,SEQ,DA)) Q:'DA D
- .... S CHILD=CHILD_+$P($G(^ORD(101.41,DLG,10,DA,0)),U,2)_"~"
- .. S $P(LST(ILST),U,10)=CHILD
- Q
- ;
- CHANGE(ORLST,ORCLST,DFN,ISIMO) ;
- N CATCH,CHANGE,CNT,INP,INPDIEN,IVM,IVMDIEN,ORIEN,ORLOC,OR3,ORDG
- N CIEN,CIVIEN,DIAL,TDIAL,TIEN,UDIEN,QORDDG,PACKIEN
- S (INP,IVM,INPDIEN,IVMDIEN,UDIEN)=0
- S (TDIAL,TIEN,CIEN,CIVIEN)=0
- S INP=$O(^ORD(101.41,"B","PSJ OR PAT OE","")) Q:INP'>0
- S IVM=$O(^ORD(101.41,"B","PSJI OR PAT FLUID OE","")) Q:IVM'>0
- S TDIAL=$O(^ORD(101.41,"B","OR GXTEXT WORD PROCESSING ORDER","")) Q:TDIAL'>0
- S INPDIEN=$O(^ORD(100.98,"B","INPATIENT MEDICATIONS","")) Q:INPDIEN'>0
- S IVMDIEN=$O(^ORD(100.98,"B","IV MEDICATIONS","")) Q:IVMDIEN'>0
- S UDIEN=$O(^ORD(100.98,"B","UNIT DOSE MEDICATIONS","")) Q:UDIEN'>0
- S TIEN=$O(^ORD(100.98,"B","NURSING","")) Q:TIEN'>0
- S CIEN=$O(^ORD(100.98,"B","CLINIC MEDICATIONS","")) Q:CIEN'>0
- S CIVIEN=$O(^ORD(100.98,"B","CLINIC INFUSIONS","")) Q:CIEN'>0
- S CNT=0 F S CNT=$O(ORCLST(CNT)) Q:CNT'>0 D
- .S CHANGE=0
- .S ORIEN=$P($G(ORCLST(CNT)),U),ORIEN=$P(ORIEN,";")
- .S ORDG=$P($G(^OR(100,ORIEN,0)),U,11)
- .S ORLOC=$P($G(ORCLST(CNT)),U,2)
- .S OR3=$G(^OR(100,ORIEN,3))
- .S DIAL=$P(OR3,U,4)
- .;Remove Treating Speciality if the order location is the clinic
- .I $P($G(^OR(100,ORIEN,0)),U,10)=(ORLOC_";SC("),$P($G(^SC(ORLOC,0)),U,3)="C" D Q
- ..S $P(^OR(100,ORIEN,0),U,13)=""
- .;
- .;CHANGE PATIENT LOCATION AND PATIENT STATUS.
- .S $P(^OR(100,ORIEN,0),U,10)=ORLOC_";SC("
- .S PACKIEN=$P(^OR(100,ORIEN,0),U,14)
- .I $$GET1^DIQ(9.4,PACKIEN_",",1)'="PSO" S $P(^OR(100,ORIEN,0),U,12)="I"
- .;
- .;Check for IMO orders Nursing Dialog problem
- .S CATCH=$P($G(^OR(100,ORIEN,0)),U,11)
- .;
- .S $P(^OR(100,ORIEN,0),U,11)=$S(DIAL=(IVM_";ORD(101.41,"):IVMDIEN,DIAL=(INP_";ORD(101.41,"):UDIEN,DIAL=(TDIAL_";ORD(101.41,"):TIEN,1:CATCH)
- .;
- .;Check for Quick Order Dialog
- .I CATCH=$P($G(^OR(100,ORIEN,0)),U,11),ISIMO=1 D
- ..S QORDDG=$P($G(^ORD(101.41,+DIAL,0)),U,5)
- ..I QORDDG=UDIEN!(QORDDG=INPDIEN) S $P(^OR(100,ORIEN,0),U,11)=UDIEN,DIAL=(INP_";ORD(101.41,") Q
- ..I QORDDG=IVMDIEN S $P(^OR(100,ORIEN,0),U,11)=IVMDIEN,DIAL=(IVM_";ORD(101.41,") Q
- ..I QORDDG=TIEN S $P(^OR(100,ORIEN,0),U,11)=TIEN,DIAL=(TDIAL_";ORD(101.41,") Q
- .;
- .;Add treating spec if Inpatient order
- .;I (ISIMO=1)&(DIAL=(IVM_";ORD(101.41,"))!(DIAL=(INP_";ORD(101.41,")) D
- .;.S $P(^OR(100,ORIEN,0),U,13)=+$G(^DPT(DFN,.103))
- .I ISIMO=0 S $P(^OR(100,ORIEN,0),U,13)=+$G(^DPT(DFN,.103))
- Q
- ;
- STCHANGE(ORY,DFN,ORYARR) ;
- N CNT,DONE,NODE,PHARMID,STR,STATUS
- S ORY=0,DONE=0
- I '$$PATCH^XPDUTL("PSS*1.0*93") Q
- S CNT=0 F S CNT=$O(ORYARR(CNT)) Q:CNT'>0!(DONE>0) D
- . S NODE=$G(ORYARR(CNT))
- . S PHARMID=$P(NODE,U),STATUS=$P(NODE,U,2)
- . I $$UP^XLFSTR(STATUS)'=$$STATUS^PSSORUTE(DFN,PHARMID) S ORY=1,DONE=1
- Q
- ORDMATCH(ORY,DFN,ORYARR) ;
- N ACTION,CNT,IEN,MATCH,ORDERID,STATUS
- S CNT=0,MATCH=1
- F S CNT=$O(ORYARR(CNT)) Q:CNT'>0!(MATCH=0) D
- . S ORDERID=$P(ORYARR(CNT),U),STATUS=$P(ORYARR(CNT),U,2)
- . ;*341 Set up Action before validation.
- . S IEN=$P(ORDERID,";"),ACTION=$P(ORDERID,";",2)
- . I ORDERID=0,$G(ACTION)="" Q
- . I STATUS=$P($G(^OR(100,IEN,3)),U,3) Q
- . I $P($G(^ORD(100.01,STATUS,0)),U)="DISCONTINUED/EDIT" Q
- . ;S MATCH=0
- . I $P($G(^OR(100,IEN,8,ACTION,0)),U,15)'=STATUS S MATCH=0
- S ORY=MATCH
- Q
- ;
- DCREN(ORY,ORYARR) ;
- N ACT,CNT,CNT1,I,OR3,ORG,ORGID,ORID,TEXT,STATUS
- S CNT1=0
- S CNT=0 F S CNT=$O(ORYARR(CNT)) Q:CNT'>0 D
- .S ORGID=ORYARR(CNT)
- .S ORID=+ORGID,ACT=$P(ORGID,";",2),TEXT=""
- .S OR3=$G(^OR(100,ORID,3))
- .;Make sure current order status is pending
- .I $P($G(^ORD(100.01,$P(OR3,U,3),0)),U)'="PENDING" Q
- .S ORG=$P($G(OR3),U,5) Q:ORG'>0
- .;do not add original order if it is expired
- .S STATUS=$P(^OR(100,ORG,3),U,3)
- .I $P($G(^ORD(100.01,STATUS,0)),U)="EXPIRED" Q
- .;Do not add original order if Stop date has pass
- .I $P(^OR(100,ORG,0),U,9)'>$$NOW^XLFDT Q
- .;make sure current order is a renewed order
- .I $P(OR3,U,11)'=2 Q
- .S ACT=+$P($G(^OR(100,ORG,3)),U,7)
- .S CNT1=CNT1+1,ORY(CNT1)=ORGID_U_$P(OR3,U,5)_";"_ACT_U_TEXT
- Q
- DCORIG(ORY,ORIEN) ;
- S $P(^OR(100,+ORIEN,6),U,9)=1
- Q
- UNDCORIG(ORY,ORYARR) ;
- N CNT
- S CNT=0 F S CNT=$O(ORYARR(CNT)) Q:CNT'>0 S $P(^OR(100,+ORYARR(CNT),6),U,9)=0
- Q
- PATWARD(ORY,DFN) ;
- N TEMP
- S ORY=""
- I $G(^DPT(DFN,.1))="" Q
- S TEMP=^DPT(DFN,.1)
- S ORY=TEMP_U_+$G(^DIC(42,+$O(^DIC(42,"B",TEMP,0)),44))
- Q
- ;
- ISPEND(ORIFN) ;Is the order's status pending?
- N ISPEND,PENDST,N3 S ISPEND=0
- Q:'$D(^OR(100,+ORIFN,3))
- S PENDST=$O(^ORD(100.01,"B","PENDING",0))
- S N3=$G(^OR(100,+ORIFN,3))
- I $P(N3,U,3)=PENDST S ISPEND=1
- Q ISPEND
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWDX1 8250 printed Feb 19, 2025@00:02:24 Page 2
- ORWDX1 ; SLC/KCM/REV - Utilities for Order Dialogs ;06/20/17 07:41
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,187,195,215,243,296,341,350,461**;Dec 17, 1997;Build 8
- +2 ;
- +3 ;
- +4 ;
- +5 ;Reference to ^PSSORUTE supported by ICR #4555
- +6 ;Reference to ^SC( supported by ICR #10040
- +7 ;Reference to ^DIC(42 supported by ICR #10039
- +8 ;Reference to ^DPT( supported by ICR #10035
- +9 ;
- WRLST(LST,LOC) ; Return list of dialogs for writing orders
- +1 ; .Y(n): DlgName^ListBox Text
- WRLST1 NEW ANENT
- +1 SET LOC=+$GET(LOC)_";SC("
- IF 'LOC
- SET LOC=""
- +2 SET ANENT="ALL^"_LOC_$SELECT($GET(^VA(200,DUZ,5)):"^SRV.`"_+$GET(^(5)),1:"")
- +3 ; check ORWDX WRITE ORDERS first
- DO WRLSTB(.LST)
- if $DATA(LST)>1
- QUIT
- +4 NEW ORX,X0,X5,ORERR,I,SEQ,IEN,DGRP,FID,TXT,TYP
- +5 DO GETLST^XPAR(.ORX,ANENT,"ORWOR WRITE ORDERS LIST","Q",.ORERR)
- if ORERR
- QUIT
- +6 SET I=0
- FOR
- SET I=$ORDER(ORX(I))
- if 'I
- QUIT
- Begin DoDot:1
- +7 SET SEQ=+ORX(I)
- SET IEN=$PIECE(ORX(I),U,2)
- SET X0=$GET(^ORD(101.41,+IEN,0))
- SET X5=$GET(^(5))
- +8 SET DGRP=+$PIECE(X0,U,5)
- SET FID=+$PIECE(X5,U,5)
- SET TXT=$PIECE(X5,U,4)
- SET TYP=$PIECE(X0,U,4)
- +9 if '$LENGTH(TXT)
- SET TXT=$PIECE(X0,U,2)
- +10 IF $PIECE(X0,U,4)="M"
- if 'FID
- SET FID=1001
- +11 SET LST(SEQ)=IEN_";"_FID_";"_DGRP_";"_TYP_U_TXT
- End DoDot:1
- +12 QUIT
- WRLSTB(LST) ; return menu from which Write Orders list is built
- +1 NEW MNU,SEQ,IEN,ITM,TXT,FID,DGRP,X,TYP
- +2 SET MNU=$$GET^XPAR(ANENT,"ORWDX WRITE ORDERS LIST",1,"I")
- if 'MNU
- QUIT
- +3 SET SEQ=0
- FOR
- SET SEQ=$ORDER(^ORD(101.41,MNU,10,"B",SEQ))
- if 'SEQ
- QUIT
- Begin DoDot:1
- +4 SET IEN=0
- FOR
- SET IEN=$ORDER(^ORD(101.41,MNU,10,"B",SEQ,IEN))
- if 'IEN
- QUIT
- Begin DoDot:2
- +5 SET X=$GET(^ORD(101.41,MNU,10,IEN,0))
- SET ITM=+$PIECE(X,U,2)
- SET TXT=$PIECE(X,U,4)
- +6 SET X=$GET(^ORD(101.41,ITM,5))
- SET FID=+$PIECE(X,U,5)
- +7 SET X=$GET(^ORD(101.41,ITM,0))
- SET TYP=$PIECE(X,U,4)
- SET DGRP=+$PIECE(X,U,5)
- +8 if '$LENGTH(TXT)
- SET TXT=$PIECE(X,U,2)
- +9 IF TYP="M"
- if 'FID
- SET FID=1001
- +10 SET LST(SEQ)=ITM_";"_FID_";"_DGRP_";"_TYP_U_TXT
- End DoDot:2
- End DoDot:1
- +11 QUIT
- DELPI ; delete PI from ORDIALOG if PI = ""
- +1 ;Called from SAVE^ORWDX
- +2 NEW ORPI
- SET ORPI=0
- +3 SET ORPI=$ORDER(^ORD(101.41,"B","OR GTX PATIENT INSTRUCTIONS",ORPI))
- +4 ;ORDIALOG is passed into SAVE^ORWDX which calls this section
- if '$DATA(ORDIALOG(ORPI))
- QUIT
- +5 IF '$DATA(ORDIALOG(ORPI,1))
- KILL ORDIALOG(ORPI),ORDIALOG("WP",ORPI)
- QUIT
- +6 NEW PINODE,PITX
- +7 SET PITX=""
- SET PINODE=$GET(ORDIALOG(ORPI,1))
- +8 SET PITX=$GET(@PINODE@(1,0))
- +9 SET PITX=$TRANSLATE(PITX," ","")
- +10 IF '$LENGTH(PITX)
- KILL ORDIALOG(ORPI),ORDIALOG("WP",ORPI)
- QUIT
- +11 NEW ORSIG
- SET ORSIG=+$ORDER(^ORD(101.41,"B","OR GTX SIG",0))
- +12 IF $$STR^ORWDXR(ORSIG)[$$STR^ORWDXR(ORPI)
- SET ORDIALOG(ORPI,"FORMAT")="@"
- +13 QUIT
- FNDINFO(Y,ODIEN) ;
- +1 NEW ODI,CRTM,FRM,XX
- +2 SET FRM=""
- SET CRTM=$$NOW^XLFDT
- +3 FOR
- SET FRM=$ORDER(^ORD(101.43,XRF,FRM))
- if FRM=""
- QUIT
- Begin DoDot:1
- +4 SET ODI=0
- FOR
- SET ODI=$ORDER(^ORD(101.43,XRF,FRM,ODI))
- if 'ODI
- QUIT
- Begin DoDot:2
- +5 ;XRF NEW'd in ORWDX which calls this section
- SET XX=^ORD(101.43,XRF,FRM,ODI)
- +6 IF +$PIECE(XX,U,3)
- IF $PIECE(XX,U,3)<CRTM
- QUIT
- +7 IF ODI=ODIEN
- Begin DoDot:3
- +8 ;variable NEW'd in ORWDX which calls this section
- SET NM=NM+1
- +9 IF 'XX
- SET Y(NM)=ODIEN_U_$PIECE(XX,U,2)_U_$PIECE(XX,U,2)
- +10 IF '$TEST
- SET Y(NM)=ODIEN_U_$PIECE(XX,U,2)_$CHAR(9)_"<"_$PIECE(XX,U,4)_">"_U_$PIECE(XX,U,4)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +11 QUIT
- DLGDEF(LST,DLG) ; Format mapping for a dlg
- +1 NEW I,IEN,ILST,X0,X2,XW
- SET ILST=0
- +2 IF $ORDER(^ORD(101.41,"AB",DLG,0))>0
- SET DLG=$ORDER(^ORD(101.41,"AB",DLG,0))
- +3 IF '$TEST
- SET DLG=$ORDER(^ORD(101.41,"B",DLG,0))
- +4 if 'DLG
- QUIT
- +5 SET I=0
- FOR
- SET I=$ORDER(^ORD(101.41,DLG,10,I))
- if I'>0
- QUIT
- Begin DoDot:1
- +6 SET X0=$GET(^ORD(101.41,DLG,10,I,0))
- SET X2=$GET(^(2))
- SET IEN=+$PIECE(X0,U,2)
- +7 SET ILST=ILST+1
- SET LST(ILST)=U_IEN_U_$PIECE(X2,U,1,7)
- +8 IF $PIECE(X0,U,11)
- SET $PIECE(LST(ILST),U,11)=1
- +9 SET $PIECE(LST(ILST),U)=$PIECE($GET(^ORD(101.41,IEN,1)),U,3)
- +10 IF $PIECE($GET(^ORD(101.41,IEN,0)),U)="OR GTX ADDITIVE"
- SET $PIECE(LST(ILST),U)="ADDITIVE"
- +11 IF $PIECE($GET(^ORD(101.41,IEN,0)),U)="OR GTX ADDL DIETS"
- SET $PIECE(LST(ILST),U)="ADDLDIETS"
- +12 IF $LENGTH($PIECE(LST(ILST),U))=0
- SET $PIECE(LST(ILST),U)="ID"_IEN
- +13 IF $DATA(^ORD(101.41,DLG,10,"DAD",IEN))
- Begin DoDot:2
- +14 NEW SEQ,DA,CHILD
- SET CHILD=""
- +15 SET SEQ=0
- FOR
- SET SEQ=$ORDER(^ORD(101.41,DLG,10,"DAD",IEN,SEQ))
- if 'SEQ
- QUIT
- Begin DoDot:3
- +16 SET DA=0
- FOR
- SET DA=$ORDER(^ORD(101.41,DLG,10,"DAD",IEN,SEQ,DA))
- if 'DA
- QUIT
- Begin DoDot:4
- +17 SET CHILD=CHILD_+$PIECE($GET(^ORD(101.41,DLG,10,DA,0)),U,2)_"~"
- End DoDot:4
- End DoDot:3
- +18 SET $PIECE(LST(ILST),U,10)=CHILD
- End DoDot:2
- End DoDot:1
- +19 QUIT
- +20 ;
- CHANGE(ORLST,ORCLST,DFN,ISIMO) ;
- +1 NEW CATCH,CHANGE,CNT,INP,INPDIEN,IVM,IVMDIEN,ORIEN,ORLOC,OR3,ORDG
- +2 NEW CIEN,CIVIEN,DIAL,TDIAL,TIEN,UDIEN,QORDDG,PACKIEN
- +3 SET (INP,IVM,INPDIEN,IVMDIEN,UDIEN)=0
- +4 SET (TDIAL,TIEN,CIEN,CIVIEN)=0
- +5 SET INP=$ORDER(^ORD(101.41,"B","PSJ OR PAT OE",""))
- if INP'>0
- QUIT
- +6 SET IVM=$ORDER(^ORD(101.41,"B","PSJI OR PAT FLUID OE",""))
- if IVM'>0
- QUIT
- +7 SET TDIAL=$ORDER(^ORD(101.41,"B","OR GXTEXT WORD PROCESSING ORDER",""))
- if TDIAL'>0
- QUIT
- +8 SET INPDIEN=$ORDER(^ORD(100.98,"B","INPATIENT MEDICATIONS",""))
- if INPDIEN'>0
- QUIT
- +9 SET IVMDIEN=$ORDER(^ORD(100.98,"B","IV MEDICATIONS",""))
- if IVMDIEN'>0
- QUIT
- +10 SET UDIEN=$ORDER(^ORD(100.98,"B","UNIT DOSE MEDICATIONS",""))
- if UDIEN'>0
- QUIT
- +11 SET TIEN=$ORDER(^ORD(100.98,"B","NURSING",""))
- if TIEN'>0
- QUIT
- +12 SET CIEN=$ORDER(^ORD(100.98,"B","CLINIC MEDICATIONS",""))
- if CIEN'>0
- QUIT
- +13 SET CIVIEN=$ORDER(^ORD(100.98,"B","CLINIC INFUSIONS",""))
- if CIEN'>0
- QUIT
- +14 SET CNT=0
- FOR
- SET CNT=$ORDER(ORCLST(CNT))
- if CNT'>0
- QUIT
- Begin DoDot:1
- +15 SET CHANGE=0
- +16 SET ORIEN=$PIECE($GET(ORCLST(CNT)),U)
- SET ORIEN=$PIECE(ORIEN,";")
- +17 SET ORDG=$PIECE($GET(^OR(100,ORIEN,0)),U,11)
- +18 SET ORLOC=$PIECE($GET(ORCLST(CNT)),U,2)
- +19 SET OR3=$GET(^OR(100,ORIEN,3))
- +20 SET DIAL=$PIECE(OR3,U,4)
- +21 ;Remove Treating Speciality if the order location is the clinic
- +22 IF $PIECE($GET(^OR(100,ORIEN,0)),U,10)=(ORLOC_";SC(")
- IF $PIECE($GET(^SC(ORLOC,0)),U,3)="C"
- Begin DoDot:2
- +23 SET $PIECE(^OR(100,ORIEN,0),U,13)=""
- End DoDot:2
- QUIT
- +24 ;
- +25 ;CHANGE PATIENT LOCATION AND PATIENT STATUS.
- +26 SET $PIECE(^OR(100,ORIEN,0),U,10)=ORLOC_";SC("
- +27 SET PACKIEN=$PIECE(^OR(100,ORIEN,0),U,14)
- +28 IF $$GET1^DIQ(9.4,PACKIEN_",",1)'="PSO"
- SET $PIECE(^OR(100,ORIEN,0),U,12)="I"
- +29 ;
- +30 ;Check for IMO orders Nursing Dialog problem
- +31 SET CATCH=$PIECE($GET(^OR(100,ORIEN,0)),U,11)
- +32 ;
- +33 SET $PIECE(^OR(100,ORIEN,0),U,11)=$SELECT(DIAL=(IVM_";ORD(101.41,"):IVMDIEN,DIAL=(INP_";ORD(101.41,"):UDIEN,DIAL=(TDIAL_";ORD(101.41,"):TIEN,1:CATCH)
- +34 ;
- +35 ;Check for Quick Order Dialog
- +36 IF CATCH=$PIECE($GET(^OR(100,ORIEN,0)),U,11)
- IF ISIMO=1
- Begin DoDot:2
- +37 SET QORDDG=$PIECE($GET(^ORD(101.41,+DIAL,0)),U,5)
- +38 IF QORDDG=UDIEN!(QORDDG=INPDIEN)
- SET $PIECE(^OR(100,ORIEN,0),U,11)=UDIEN
- SET DIAL=(INP_";ORD(101.41,")
- QUIT
- +39 IF QORDDG=IVMDIEN
- SET $PIECE(^OR(100,ORIEN,0),U,11)=IVMDIEN
- SET DIAL=(IVM_";ORD(101.41,")
- QUIT
- +40 IF QORDDG=TIEN
- SET $PIECE(^OR(100,ORIEN,0),U,11)=TIEN
- SET DIAL=(TDIAL_";ORD(101.41,")
- QUIT
- End DoDot:2
- +41 ;
- +42 ;Add treating spec if Inpatient order
- +43 ;I (ISIMO=1)&(DIAL=(IVM_";ORD(101.41,"))!(DIAL=(INP_";ORD(101.41,")) D
- +44 ;.S $P(^OR(100,ORIEN,0),U,13)=+$G(^DPT(DFN,.103))
- +45 IF ISIMO=0
- SET $PIECE(^OR(100,ORIEN,0),U,13)=+$GET(^DPT(DFN,.103))
- End DoDot:1
- +46 QUIT
- +47 ;
- STCHANGE(ORY,DFN,ORYARR) ;
- +1 NEW CNT,DONE,NODE,PHARMID,STR,STATUS
- +2 SET ORY=0
- SET DONE=0
- +3 IF '$$PATCH^XPDUTL("PSS*1.0*93")
- QUIT
- +4 SET CNT=0
- FOR
- SET CNT=$ORDER(ORYARR(CNT))
- if CNT'>0!(DONE>0)
- QUIT
- Begin DoDot:1
- +5 SET NODE=$GET(ORYARR(CNT))
- +6 SET PHARMID=$PIECE(NODE,U)
- SET STATUS=$PIECE(NODE,U,2)
- +7 IF $$UP^XLFSTR(STATUS)'=$$STATUS^PSSORUTE(DFN,PHARMID)
- SET ORY=1
- SET DONE=1
- End DoDot:1
- +8 QUIT
- ORDMATCH(ORY,DFN,ORYARR) ;
- +1 NEW ACTION,CNT,IEN,MATCH,ORDERID,STATUS
- +2 SET CNT=0
- SET MATCH=1
- +3 FOR
- SET CNT=$ORDER(ORYARR(CNT))
- if CNT'>0!(MATCH=0)
- QUIT
- Begin DoDot:1
- +4 SET ORDERID=$PIECE(ORYARR(CNT),U)
- SET STATUS=$PIECE(ORYARR(CNT),U,2)
- +5 ;*341 Set up Action before validation.
- +6 SET IEN=$PIECE(ORDERID,";")
- SET ACTION=$PIECE(ORDERID,";",2)
- +7 IF ORDERID=0
- IF $GET(ACTION)=""
- QUIT
- +8 IF STATUS=$PIECE($GET(^OR(100,IEN,3)),U,3)
- QUIT
- +9 IF $PIECE($GET(^ORD(100.01,STATUS,0)),U)="DISCONTINUED/EDIT"
- QUIT
- +10 ;S MATCH=0
- +11 IF $PIECE($GET(^OR(100,IEN,8,ACTION,0)),U,15)'=STATUS
- SET MATCH=0
- End DoDot:1
- +12 SET ORY=MATCH
- +13 QUIT
- +14 ;
- DCREN(ORY,ORYARR) ;
- +1 NEW ACT,CNT,CNT1,I,OR3,ORG,ORGID,ORID,TEXT,STATUS
- +2 SET CNT1=0
- +3 SET CNT=0
- FOR
- SET CNT=$ORDER(ORYARR(CNT))
- if CNT'>0
- QUIT
- Begin DoDot:1
- +4 SET ORGID=ORYARR(CNT)
- +5 SET ORID=+ORGID
- SET ACT=$PIECE(ORGID,";",2)
- SET TEXT=""
- +6 SET OR3=$GET(^OR(100,ORID,3))
- +7 ;Make sure current order status is pending
- +8 IF $PIECE($GET(^ORD(100.01,$PIECE(OR3,U,3),0)),U)'="PENDING"
- QUIT
- +9 SET ORG=$PIECE($GET(OR3),U,5)
- if ORG'>0
- QUIT
- +10 ;do not add original order if it is expired
- +11 SET STATUS=$PIECE(^OR(100,ORG,3),U,3)
- +12 IF $PIECE($GET(^ORD(100.01,STATUS,0)),U)="EXPIRED"
- QUIT
- +13 ;Do not add original order if Stop date has pass
- +14 IF $PIECE(^OR(100,ORG,0),U,9)'>$$NOW^XLFDT
- QUIT
- +15 ;make sure current order is a renewed order
- +16 IF $PIECE(OR3,U,11)'=2
- QUIT
- +17 SET ACT=+$PIECE($GET(^OR(100,ORG,3)),U,7)
- +18 SET CNT1=CNT1+1
- SET ORY(CNT1)=ORGID_U_$PIECE(OR3,U,5)_";"_ACT_U_TEXT
- End DoDot:1
- +19 QUIT
- DCORIG(ORY,ORIEN) ;
- +1 SET $PIECE(^OR(100,+ORIEN,6),U,9)=1
- +2 QUIT
- UNDCORIG(ORY,ORYARR) ;
- +1 NEW CNT
- +2 SET CNT=0
- FOR
- SET CNT=$ORDER(ORYARR(CNT))
- if CNT'>0
- QUIT
- SET $PIECE(^OR(100,+ORYARR(CNT),6),U,9)=0
- +3 QUIT
- PATWARD(ORY,DFN) ;
- +1 NEW TEMP
- +2 SET ORY=""
- +3 IF $GET(^DPT(DFN,.1))=""
- QUIT
- +4 SET TEMP=^DPT(DFN,.1)
- +5 SET ORY=TEMP_U_+$GET(^DIC(42,+$ORDER(^DIC(42,"B",TEMP,0)),44))
- +6 QUIT
- +7 ;
- ISPEND(ORIFN) ;Is the order's status pending?
- +1 NEW ISPEND,PENDST,N3
- SET ISPEND=0
- +2 if '$DATA(^OR(100,+ORIFN,3))
- QUIT
- +3 SET PENDST=$ORDER(^ORD(100.01,"B","PENDING",0))
- +4 SET N3=$GET(^OR(100,+ORIFN,3))
- +5 IF $PIECE(N3,U,3)=PENDST
- SET ISPEND=1
- +6 QUIT ISPEND