- ORCDVBEC ;SLC/MKB-Utility functions for VBECS dialogs ;2/11/08 11:04
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**212,309,332**;Dec 17, 1997;Build 44
- ;
- ; External References:
- ; OEAPI^VBECA3 #4766
- ; RR^LR7OR1 #2503
- ; GCOM^LR7OR3 #2428
- ; $$SITE^VASITE #10112
- ; $$HL7TFM^XLFDT #10103
- ; $$UP^XLFSTR #10104
- ;
- PTR(X) ; -- Returns pointer to #101.41 of prompt OR GTX X
- Q +$O(^ORD(101.41,"AB","OR GTX "_X,0))
- ;
- EN ; -- entry action
- I '$L($T(OEAPI^VBECA3)) W $C(7),!!,"Blood Bank orders are not available yet!" H 2 S ORQUIT=1 Q
- N DIV,ORSTN,C,N,X S DIV=+$P($G(^SC(+$G(ORL),0)),U,15)
- S ORSTN=$P($$SITE^VASITE(DT,DIV),U,3)
- I $G(ORTYPE)'="Z" D OEAPI^VBECA3(.ORVB,+ORVP,ORSTN),PTINFO^ORCDVBC1
- I $G(OREVENT) S ORVB("SPECIMEN")="" ;assume no specimen if delayed
- S C=0 F S C=$O(ORVB(C)) Q:C<1 S N=0 F S N=$O(ORVB(C,"MSBOS",N)) Q:N<1 S X=$G(ORVB(C,"MSBOS",N)),ORMSBOS(C,$P(X,U))=$P(X,U,2) ;sort
- ;get initial state: ORCOMP/ORTEST = id^id^ ^id, ORTAS = 1 or 0:
- S (ORCOMP,ORTEST,ORTAS)="" I $D(OREDIT)!$G(OREWRITE) D
- . N P,I,X,X0 S P=$$PTR("ORDERABLE ITEM")
- . S I=0 F S I=$O(ORDIALOG(P,I)) Q:I<1 S X=+$G(ORDIALOG(P,I)) D
- .. S X0=$G(^ORD(101.43,X,"VB")),X=+$P($G(^(0)),U,2)
- .. I $P(X0,U) S ORCOMP=ORCOMP_$S($L(ORCOMP):U,1:"")_X Q
- .. S ORTEST=ORTEST_$S($L(ORTEST):U,1:"")_X
- Q
- ;
- EX ; -- exit action
- K ORITM,ORCOMP,ORTEST,ORTAS,ORMSBOS,ORTIME,ORIMTIME,ORDIV,ORCOLLCT,ORVB,ORASK,ORSURG
- I $G(ORXL) S ORL=ORXL K ORXL
- Q
- ;
- XHELP ; -- display OI's in groups
- N INDEX,CNT,SCREEN,X,Y,SYN,Y0,D,Z,DONE
- S CNT=1,SCREEN=$G(ORDIALOG(PROMPT,"S"))
- F INDEX="S.VBC","S.VBT" D Q:$G(DONE)
- . W !!,$S(INDEX["C":"Choose from Blood Components:",1:"or Diagnostic Tests:")
- . S X="" F S X=$O(^ORD(101.43,INDEX,X)) Q:X="" S Y=0 D Q:$G(DONE)
- .. F S Y=$O(^ORD(101.43,INDEX,X,Y)) Q:Y'>0 S SYN=$G(^(Y)) I 'SYN D Q:$G(DONE)
- ... S Y0=$G(^ORD(101.43,Y,0)),D=INDEX X:$L(SCREEN) SCREEN Q:'$T
- ... W !," "_X ;W:SYN " "_$P(SYN,U,4) ; echo .01 if synonym
- ... S CNT=CNT+1 Q:CNT'>(IOSL-5) S CNT=0
- ... W !," '^' TO STOP: " R Z:DTIME S:'$T!(Z["^") DONE=1
- W !
- Q
- ;
- PSAOI ; -- set ORASK flags or show GenWrdInstructions for OI instance
- I $$DUP^ORCD(PROMPT,ORI) K DONE W $C(7),!,"This component or test has already been selected!",! Q
- N X0,NAME,ORT,ORWRD,WRD,I
- S ORASK=+$G(^ORD(101.43,+$G(Y),"VB")),X0=$G(^(0)) ;VBEC OI
- Q:ORASK Q:$G(ORESET)=+$G(Y) ;get ward instr for new tests
- S NAME=$P(X0,U,8),ORT=+$$TEST^ORCSEND2(NAME) ;corresponding Lab OI
- S ORT=+$P($G(^ORD(101.43,ORT,0)),U,2) ;#60 ien
- D GCOM^LR7OR3(ORT,.ORWRD) S WRD="GenWardInstructions"
- I $O(ORWRD(WRD,0)) W !! S I=0 F S I=$O(ORWRD(WRD,I)) Q:I'>0 W ORWRD(WRD,I,0),!
- Q
- ;
- MOD ; -- get allowable modifier values
- Q:$G(ORDIALOG(PROMPT,"LIST")) N ORX,I,X
- D GETLST^XPAR(.ORX,"ALL","OR VBECS MODIFIERS","Q")
- S I=0 F S I=$O(ORX(I)) Q:I<1 D
- . S X=$P($G(ORX(I)),U,2) Q:'$L(X)
- . S ORDIALOG(PROMPT,"LIST",I)=X_U_X
- . S ORDIALOG(PROMPT,"LIST","B",$$UP^XLFSTR(X))=X
- S:ORX ORDIALOG(PROMPT,"LIST")=ORX_"^1"
- Q
- ;
- PSAMT ; -- Post-Selection Action for Amount, to validate and format
- ; only allow numeric entry for now, until GUI can accept volume
- N X,X1,X2
- I +Y'=Y W !,$C(7),"Enter the number of units needed, from 1-99." K DONE Q
- S X=$$UP^XLFSTR(Y),X1=+X ;,X2=$$STRIP($P(X,X1,2))
- ;I X2="ML" S ORDIALOG(PROMPT,ORI)=X1_"ml" Q
- I (X1<1)!(X1>99) W !,$C(7),"Enter the number of units needed, from 1-99." K DONE Q ;!("UNITS"'[X2)
- S ORDIALOG(PROMPT,ORI)=X1 ;_" unit"_$S(X1>1:"s",1:"")
- Q
- ;
- SPCSTS ; -- set Specimen Status by component [Entry Action]
- I '$G(ORASK) K ORDIALOG(PROMPT,INST) Q ;not a component
- N OI,X S OI=+$G(ORDIALOG($$PTR("ORDERABLE ITEM"),INST))
- S X=+$P($G(^ORD(101.43,OI,0)),U,2)
- S ORDIALOG(PROMPT,INST)=$G(ORVB(X,"SPECIMEN"))_U_$G(ORVB("SPECIMEN"))
- Q
- ;
- EXOI ; -- setup dialog parameters for selected items
- N ORI,X,X0,TEST,COMP
- S (ORTAS,TEST,COMP)="" K ORASK
- S ORI=0 F S ORI=$O(ORDIALOG(PROMPT,ORI)) Q:ORI<1 D
- . S X=+$G(ORDIALOG(PROMPT,ORI)),X0=$G(^ORD(101.43,X,"VB")),X=+$P($G(^(0)),U,2)
- . I $P(X0,U) S COMP=COMP_$S($L(COMP):U,1:"")_X Q
- . S TEST=TEST_$S($L(TEST):U,1:"")_X S:$P(X0,U,2)>1 ORTAS=1
- I ORTEST'=TEST S ORTEST=TEST K ORTEST("Lab CollSamp")
- I ORCOMP'=COMP S ORCOMP=COMP D CHANGED:'FIRST,COMP:COMP
- I ORCOMP,U[$G(ORVB("ABORH")),'ORTAS,$G(ORTYPE)'="Z" D ADDTAS
- Q
- ;
- COMP ; -- Handle component-specific tasks [from EXOI]
- ; Uses ORCOMP, ORVB(comp)
- Q:$G(ORTYPE)="Z" ;QO editor
- N ORP,ORI,ORT,ORTST,ORTMP,ORTDT,ORZ,ORHDR,OROOT,N
- F ORI=1:1:$L(ORCOMP,U) S ORC=$P(ORCOMP,U,ORI) D
- . S N=0 F S N=$O(ORVB(ORC,"TEST",N)) Q:N<1 S ORT=+$G(ORVB(ORC,"TEST",N)),ORTST(ORT)=""
- . I $G(ORVB(ORC,"SPECIMEN")),$P($G(ORVB("SPECIMEN")),U,2)="",'ORTAS D ADDTAS
- C1 S ORP=$$PTR("RESULTS"),(ORI,ORT)=0 F S ORT=+$O(ORTST(ORT)) Q:ORT<1 D
- . K ^TMP("LRRR",$J) D RR^LR7OR1(+ORVP,,,,,ORT,,1)
- . ;S ORTMP="^TMP(""LRRR"",$J,+ORVP)",ORTMP=$Q(@ORTMP)
- . ;Q:$P(ORTMP,",",1,3)'=("^TMP(""LRRR"","_$J_","_+ORVP)
- . S ORTMP=$$FIRST(+ORVP,ORT) Q:'$L(ORTMP)
- . S ORTDT=9999999-+$P(ORTMP,",",5),ORZ=@ORTMP
- . S ORI=ORI+1,ORDIALOG(ORP,ORI)=$P(ORZ,U,1,6)_U_ORTDT
- . W:'$G(ORHDR) !!,"RECENT LAB RESULTS:",!,"Test Result Units Range Collected Accession Sts"
- . W:'$G(ORHDR) !,"---- ------ ----- ----- --------- --------- ---"
- . W !,$$PAD^ORCHTAB($P(ORZ,U,15),8)_$J($P(ORZ,U,2),9)_" "_$$PAD^ORCHTAB($P(ORZ,U,3),3)_$$PAD^ORCHTAB($P(ORZ,U,4),11)_$$PAD^ORCHTAB($P(ORZ,U,5),10)_$$DATETIME^ORCHTAB(ORTDT)_" "_$$PAD^ORCHTAB($P(ORZ,U,16),15)_$P(ORZ,U,6)
- . S ORHDR=1,OROOT=$P(ORTMP,",",1,5)_",""N""" ;ck for comments
- . F S ORTMP=$Q(@ORTMP) Q:$P(ORTMP,",",1,6)'=OROOT W !," "_@ORTMP
- W:$G(ORHDR) ! K ^TMP("LRRR",$J)
- W !!,"NOTE: The nursing blood administration order must be entered separately."
- Q
- ;
- FIRST(DFN,TEST) ; -- returns array reference to first data node
- ; in ^TMP("LRRR",$J,DFN) for TEST
- N Y,IDT,DA S Y=""
- S IDT=0 F S IDT=$O(^TMP("LRRR",$J,DFN,"CH",IDT)) Q:IDT<1 D Q:Y
- . S DA=0 F S DA=$O(^TMP("LRRR",$J,DFN,"CH",IDT,DA)) Q:DA<1 I +$G(^(DA))=TEST S Y=1 Q
- I Y S Y=$NA(^TMP("LRRR",$J,DFN,"CH",IDT,DA))
- Q Y
- ;
- ADDTAS ; -- adds T&S to order, sets ORTAS=1
- ; Expects PROMPT=OI, ORTEST
- N ORI S ORI=$O(ORDIALOG(PROMPT,"?"),-1),ORI=ORI+1
- S ORDIALOG(PROMPT,ORI)=+$O(^ORD(101.43,"ID","1;99VBC",0))
- W !!,"Type & Screen added for new specimen."
- S ORTAS=1,ORTEST=$G(ORTEST)_$S($L($G(ORTEST)):U,1:"")_"1"
- Q
- ;
- CHANGED ; -- Kill dependent values when Component changes
- N PTR,I,J
- F I="FREE TEXT","RESULTS" S PTR=$$PTR(I) I PTR D
- . S J=0 F S J=$O(ORDIALOG(PTR,J)) Q:J<1 K ORDIALOG(PTR,J)
- . K ORDIALOG(PTR,"LIST")
- Q
- ;
- DTW ; -- Comp D/T Wanted to specimen exp d/t for TAS [DTW Exit Action]
- Q:'$G(ORVB("SPECIMEN")) Q:$G(ORTYPE)="Z"
- N X,Y,%DT,EXP,OK
- S X=$G(ORDIALOG(PROMPT,INST)),%DT="T" D ^%DT Q:Y<1
- S EXP=$$HL7TFM^XLFDT(+$G(ORVB("SPECIMEN"))),OK=1
- I EXP<Y D:'$G(ORTAS) ADDTAS S OK=0
- D UID(OK) ;[re]set Specimen UID
- Q
- ;
- UID(OK) ; -- [re]set the Specimen UID if DTW changes
- N SPCSTS,I,X
- S SPCSTS=$$PTR("SPECIMEN STATUS")
- S I=0 F S I=$O(ORDIALOG(SPCSTS,I)) Q:I<1 D
- . S X=$P(ORDIALOG(SPCSTS,I),U)_U_$S($G(OK):$G(ORVB("SPECIMEN")),1:"^")
- . S ORDIALOG(SPCSTS,I)=X
- Q
- ;
- REASON ; -- get allowable reasons
- Q:$G(ORDIALOG(PROMPT,"LIST")) N ORX,I,X
- D GETLST^XPAR(.ORX,"ALL","OR VBECS REASON FOR REQUEST","Q")
- S I=0 F S I=$O(ORX(I)) Q:I<1 D
- . S X=$P($G(ORX(I)),U,2) Q:'$L(X)
- . S ORDIALOG(PROMPT,"LIST",I)=X_U_X
- . S ORDIALOG(PROMPT,"LIST","B",$$UP^XLFSTR(X))=X
- S:ORX ORDIALOG(PROMPT,"LIST")=ORX ;_"^1"
- Q
- ;
- ENTYPE ; -- set up Coll Type
- I '$D(ORTEST("Lab CollSamp")) D
- . N I,V,T,LC S LC=1
- . F I=1:1:$L(ORTEST,U) S V=+$P(ORTEST,U,I) D Q:'LC ;no LC samp
- .. S T=$$LAB60(V) ;VBECS ID -> #60 ien
- .. I '$P($G(^LAB(60,T,0)),U,9) S LC=0 Q
- . S ORTEST("Lab CollSamp")=LC
- I '$D(ORTIME),'$D(ORIMTIME) D GETIMES^ORCDLR1
- Q
- ;
- LAB60(X) ; -- Return file 60 ien for VBECS OI ID
- N Y,I,NM
- S I=$O(^ORD(101.43,"ID",+X_";99VBC",0)),NM=$P($G(^ORD(101.43,+I,0)),U)_" - LAB"
- S Y=+$O(^LAB(60,"B",NM,0))
- Q Y
- ;
- ENSURG ; -- Get list of surgeries from ORVB("SURGERY")
- S:$P($G(^ORD(101.42,+$$VAL^ORCD("URGENCY"),0)),U,2)="P" REQD=1
- Q:$G(ORDIALOG(PROMPT,"LIST")) K ORSURG
- N I,CNT,X S (I,CNT)=0
- F S I=$O(ORVB("SURGERY",I)) Q:I'>0 S X=$G(ORVB("SURGERY",I)) D
- . S ORSURG($P(X,U))=$P(X,U,2),X=$P(X,U) ;ORSURG(name)=NoBloodReqd
- . S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=X_U_X
- . S ORDIALOG(PROMPT,"LIST","B",$$UP^XLFSTR(X))=X
- S:CNT ORDIALOG(PROMPT,"LIST")=CNT_"^1"
- Q
- ;
- CKMSBOS ; -- check if MSBOS limit exists, was exceeded [from PSA]
- Q:'$L($G(Y)) N OI,AMT,I,X,COMP,LIMIT
- I ORCOMP,$G(ORSURG($P(Y,U))) W !," >> No blood is required for this procedure!",! Q
- S OI=$$PTR("ORDERABLE ITEM"),AMT=$$PTR("AMOUNT")
- S I=0 F S I=$O(ORDIALOG(OI,I)) Q:I<1 D
- . S X=ORDIALOG(OI,I),COMP=+$P($G(^ORD(101.43,+X,0)),U,2)
- . S LIMIT=$G(ORMSBOS(COMP,$P(Y,U))) Q:LIMIT=""
- . Q:$G(ORDIALOG(AMT,I))'>LIMIT
- . W !," >> Requested #units of "_$P($G(^ORD(101.43,+X,0)),U)_" exceeds MSBOS limit of "_LIMIT_"!",!
- Q
- ;
- ENURG ; -- Get list of urgencies from #101.42, parameter
- Q:$G(ORDIALOG(PROMPT,"LIST")) N I,CNT,X S CNT=0
- S X="" F S X=$O(^ORD(101.42,"S.VBEC",X)) Q:X="" D
- . ;I X="STAT" Q:'$$GET^XPAR("ALL","OR VBECS STAT USER")
- . ;I X="STAT",'$D(^XUSEC("ORES",DUZ)),'$D(^XUSEC("ORELSE",DUZ)) Q
- . S I=0 F S I=$O(^ORD(101.42,"S.VBEC",X,I)) Q:I<1 D
- .. S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=I_U_X
- .. S ORDIALOG(PROMPT,"LIST","B",$$UP^XLFSTR(X))=I
- S:CNT ORDIALOG(PROMPT,"LIST")=CNT_"^1"
- Q
- ;
- ASKURG() ; -- ask unless PreOp, set default
- N Y S Y=1
- I FIRST,'$D(ORDIALOG(PROMPT,INST)),$G(ORTYPE)'="Z" D
- . I $$PREOP S ORDIALOG(PROMPT,INST)=+$O(^ORD(101.42,"C","P",0)),Y=0 Q
- . S ORDIALOG(PROMPT,INST)=9 ;default
- Q Y
- ;
- PREOP() ; -- Returns 1 or 0, if order is for pre-op
- N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
- S DIR(0)="YAO",DIR("A")="Is this order for pre-op? "
- S DIR("?")="If YES, the urgency will be set to PRE-OP and a surgery name will be required"
- S DIR("B")="NO" D ^DIR S:$D(DTOUT)!($D(DUOUT)) ORQUIT=1
- Q +Y
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCDVBEC 10230 printed Feb 18, 2025@23:54:50 Page 2
- ORCDVBEC ;SLC/MKB-Utility functions for VBECS dialogs ;2/11/08 11:04
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**212,309,332**;Dec 17, 1997;Build 44
- +2 ;
- +3 ; External References:
- +4 ; OEAPI^VBECA3 #4766
- +5 ; RR^LR7OR1 #2503
- +6 ; GCOM^LR7OR3 #2428
- +7 ; $$SITE^VASITE #10112
- +8 ; $$HL7TFM^XLFDT #10103
- +9 ; $$UP^XLFSTR #10104
- +10 ;
- PTR(X) ; -- Returns pointer to #101.41 of prompt OR GTX X
- +1 QUIT +$ORDER(^ORD(101.41,"AB","OR GTX "_X,0))
- +2 ;
- EN ; -- entry action
- +1 IF '$LENGTH($TEXT(OEAPI^VBECA3))
- WRITE $CHAR(7),!!,"Blood Bank orders are not available yet!"
- HANG 2
- SET ORQUIT=1
- QUIT
- +2 NEW DIV,ORSTN,C,N,X
- SET DIV=+$PIECE($GET(^SC(+$GET(ORL),0)),U,15)
- +3 SET ORSTN=$PIECE($$SITE^VASITE(DT,DIV),U,3)
- +4 IF $GET(ORTYPE)'="Z"
- DO OEAPI^VBECA3(.ORVB,+ORVP,ORSTN)
- DO PTINFO^ORCDVBC1
- +5 ;assume no specimen if delayed
- IF $GET(OREVENT)
- SET ORVB("SPECIMEN")=""
- +6 ;sort
- SET C=0
- FOR
- SET C=$ORDER(ORVB(C))
- if C<1
- QUIT
- SET N=0
- FOR
- SET N=$ORDER(ORVB(C,"MSBOS",N))
- if N<1
- QUIT
- SET X=$GET(ORVB(C,"MSBOS",N))
- SET ORMSBOS(C,$PIECE(X,U))=$PIECE(X,U,2)
- +7 ;get initial state: ORCOMP/ORTEST = id^id^ ^id, ORTAS = 1 or 0:
- +8 SET (ORCOMP,ORTEST,ORTAS)=""
- IF $DATA(OREDIT)!$GET(OREWRITE)
- Begin DoDot:1
- +9 NEW P,I,X,X0
- SET P=$$PTR("ORDERABLE ITEM")
- +10 SET I=0
- FOR
- SET I=$ORDER(ORDIALOG(P,I))
- if I<1
- QUIT
- SET X=+$GET(ORDIALOG(P,I))
- Begin DoDot:2
- +11 SET X0=$GET(^ORD(101.43,X,"VB"))
- SET X=+$PIECE($GET(^(0)),U,2)
- +12 IF $PIECE(X0,U)
- SET ORCOMP=ORCOMP_$SELECT($LENGTH(ORCOMP):U,1:"")_X
- QUIT
- +13 SET ORTEST=ORTEST_$SELECT($LENGTH(ORTEST):U,1:"")_X
- End DoDot:2
- End DoDot:1
- +14 QUIT
- +15 ;
- EX ; -- exit action
- +1 KILL ORITM,ORCOMP,ORTEST,ORTAS,ORMSBOS,ORTIME,ORIMTIME,ORDIV,ORCOLLCT,ORVB,ORASK,ORSURG
- +2 IF $GET(ORXL)
- SET ORL=ORXL
- KILL ORXL
- +3 QUIT
- +4 ;
- XHELP ; -- display OI's in groups
- +1 NEW INDEX,CNT,SCREEN,X,Y,SYN,Y0,D,Z,DONE
- +2 SET CNT=1
- SET SCREEN=$GET(ORDIALOG(PROMPT,"S"))
- +3 FOR INDEX="S.VBC","S.VBT"
- Begin DoDot:1
- +4 WRITE !!,$SELECT(INDEX["C":"Choose from Blood Components:",1:"or Diagnostic Tests:")
- +5 SET X=""
- FOR
- SET X=$ORDER(^ORD(101.43,INDEX,X))
- if X=""
- QUIT
- SET Y=0
- Begin DoDot:2
- +6 FOR
- SET Y=$ORDER(^ORD(101.43,INDEX,X,Y))
- if Y'>0
- QUIT
- SET SYN=$GET(^(Y))
- IF 'SYN
- Begin DoDot:3
- +7 SET Y0=$GET(^ORD(101.43,Y,0))
- SET D=INDEX
- if $LENGTH(SCREEN)
- XECUTE SCREEN
- if '$TEST
- QUIT
- +8 ;W:SYN " "_$P(SYN,U,4) ; echo .01 if synonym
- WRITE !," "_X
- +9 SET CNT=CNT+1
- if CNT'>(IOSL-5)
- QUIT
- SET CNT=0
- +10 WRITE !," '^' TO STOP: "
- READ Z:DTIME
- if '$TEST!(Z["^")
- SET DONE=1
- End DoDot:3
- if $GET(DONE)
- QUIT
- End DoDot:2
- if $GET(DONE)
- QUIT
- End DoDot:1
- if $GET(DONE)
- QUIT
- +11 WRITE !
- +12 QUIT
- +13 ;
- PSAOI ; -- set ORASK flags or show GenWrdInstructions for OI instance
- +1 IF $$DUP^ORCD(PROMPT,ORI)
- KILL DONE
- WRITE $CHAR(7),!,"This component or test has already been selected!",!
- QUIT
- +2 NEW X0,NAME,ORT,ORWRD,WRD,I
- +3 ;VBEC OI
- SET ORASK=+$GET(^ORD(101.43,+$GET(Y),"VB"))
- SET X0=$GET(^(0))
- +4 ;get ward instr for new tests
- if ORASK
- QUIT
- if $GET(ORESET)=+$GET(Y)
- QUIT
- +5 ;corresponding Lab OI
- SET NAME=$PIECE(X0,U,8)
- SET ORT=+$$TEST^ORCSEND2(NAME)
- +6 ;#60 ien
- SET ORT=+$PIECE($GET(^ORD(101.43,ORT,0)),U,2)
- +7 DO GCOM^LR7OR3(ORT,.ORWRD)
- SET WRD="GenWardInstructions"
- +8 IF $ORDER(ORWRD(WRD,0))
- WRITE !!
- SET I=0
- FOR
- SET I=$ORDER(ORWRD(WRD,I))
- if I'>0
- QUIT
- WRITE ORWRD(WRD,I,0),!
- +9 QUIT
- +10 ;
- MOD ; -- get allowable modifier values
- +1 if $GET(ORDIALOG(PROMPT,"LIST"))
- QUIT
- NEW ORX,I,X
- +2 DO GETLST^XPAR(.ORX,"ALL","OR VBECS MODIFIERS","Q")
- +3 SET I=0
- FOR
- SET I=$ORDER(ORX(I))
- if I<1
- QUIT
- Begin DoDot:1
- +4 SET X=$PIECE($GET(ORX(I)),U,2)
- if '$LENGTH(X)
- QUIT
- +5 SET ORDIALOG(PROMPT,"LIST",I)=X_U_X
- +6 SET ORDIALOG(PROMPT,"LIST","B",$$UP^XLFSTR(X))=X
- End DoDot:1
- +7 if ORX
- SET ORDIALOG(PROMPT,"LIST")=ORX_"^1"
- +8 QUIT
- +9 ;
- PSAMT ; -- Post-Selection Action for Amount, to validate and format
- +1 ; only allow numeric entry for now, until GUI can accept volume
- +2 NEW X,X1,X2
- +3 IF +Y'=Y
- WRITE !,$CHAR(7),"Enter the number of units needed, from 1-99."
- KILL DONE
- QUIT
- +4 ;,X2=$$STRIP($P(X,X1,2))
- SET X=$$UP^XLFSTR(Y)
- SET X1=+X
- +5 ;I X2="ML" S ORDIALOG(PROMPT,ORI)=X1_"ml" Q
- +6 ;!("UNITS"'[X2)
- IF (X1<1)!(X1>99)
- WRITE !,$CHAR(7),"Enter the number of units needed, from 1-99."
- KILL DONE
- QUIT
- +7 ;_" unit"_$S(X1>1:"s",1:"")
- SET ORDIALOG(PROMPT,ORI)=X1
- +8 QUIT
- +9 ;
- SPCSTS ; -- set Specimen Status by component [Entry Action]
- +1 ;not a component
- IF '$GET(ORASK)
- KILL ORDIALOG(PROMPT,INST)
- QUIT
- +2 NEW OI,X
- SET OI=+$GET(ORDIALOG($$PTR("ORDERABLE ITEM"),INST))
- +3 SET X=+$PIECE($GET(^ORD(101.43,OI,0)),U,2)
- +4 SET ORDIALOG(PROMPT,INST)=$GET(ORVB(X,"SPECIMEN"))_U_$GET(ORVB("SPECIMEN"))
- +5 QUIT
- +6 ;
- EXOI ; -- setup dialog parameters for selected items
- +1 NEW ORI,X,X0,TEST,COMP
- +2 SET (ORTAS,TEST,COMP)=""
- KILL ORASK
- +3 SET ORI=0
- FOR
- SET ORI=$ORDER(ORDIALOG(PROMPT,ORI))
- if ORI<1
- QUIT
- Begin DoDot:1
- +4 SET X=+$GET(ORDIALOG(PROMPT,ORI))
- SET X0=$GET(^ORD(101.43,X,"VB"))
- SET X=+$PIECE($GET(^(0)),U,2)
- +5 IF $PIECE(X0,U)
- SET COMP=COMP_$SELECT($LENGTH(COMP):U,1:"")_X
- QUIT
- +6 SET TEST=TEST_$SELECT($LENGTH(TEST):U,1:"")_X
- if $PIECE(X0,U,2)>1
- SET ORTAS=1
- End DoDot:1
- +7 IF ORTEST'=TEST
- SET ORTEST=TEST
- KILL ORTEST("Lab CollSamp")
- +8 IF ORCOMP'=COMP
- SET ORCOMP=COMP
- if 'FIRST
- DO CHANGED
- if COMP
- DO COMP
- +9 IF ORCOMP
- IF U[$GET(ORVB("ABORH"))
- IF 'ORTAS
- IF $GET(ORTYPE)'="Z"
- DO ADDTAS
- +10 QUIT
- +11 ;
- COMP ; -- Handle component-specific tasks [from EXOI]
- +1 ; Uses ORCOMP, ORVB(comp)
- +2 ;QO editor
- if $GET(ORTYPE)="Z"
- QUIT
- +3 NEW ORP,ORI,ORT,ORTST,ORTMP,ORTDT,ORZ,ORHDR,OROOT,N
- +4 FOR ORI=1:1:$LENGTH(ORCOMP,U)
- SET ORC=$PIECE(ORCOMP,U,ORI)
- Begin DoDot:1
- +5 SET N=0
- FOR
- SET N=$ORDER(ORVB(ORC,"TEST",N))
- if N<1
- QUIT
- SET ORT=+$GET(ORVB(ORC,"TEST",N))
- SET ORTST(ORT)=""
- +6 IF $GET(ORVB(ORC,"SPECIMEN"))
- IF $PIECE($GET(ORVB("SPECIMEN")),U,2)=""
- IF 'ORTAS
- DO ADDTAS
- End DoDot:1
- C1 SET ORP=$$PTR("RESULTS")
- SET (ORI,ORT)=0
- FOR
- SET ORT=+$ORDER(ORTST(ORT))
- if ORT<1
- QUIT
- Begin DoDot:1
- +1 KILL ^TMP("LRRR",$JOB)
- DO RR^LR7OR1(+ORVP,,,,,ORT,,1)
- +2 ;S ORTMP="^TMP(""LRRR"",$J,+ORVP)",ORTMP=$Q(@ORTMP)
- +3 ;Q:$P(ORTMP,",",1,3)'=("^TMP(""LRRR"","_$J_","_+ORVP)
- +4 SET ORTMP=$$FIRST(+ORVP,ORT)
- if '$LENGTH(ORTMP)
- QUIT
- +5 SET ORTDT=9999999-+$PIECE(ORTMP,",",5)
- SET ORZ=@ORTMP
- +6 SET ORI=ORI+1
- SET ORDIALOG(ORP,ORI)=$PIECE(ORZ,U,1,6)_U_ORTDT
- +7 if '$GET(ORHDR)
- WRITE !!,"RECENT LAB RESULTS:",!,"Test Result Units Range Collected Accession Sts"
- +8 if '$GET(ORHDR)
- WRITE !,"---- ------ ----- ----- --------- --------- ---"
- +9 WRITE !,$$PAD^ORCHTAB($PIECE(ORZ,U,15),8)_$JUSTIFY($PIECE(ORZ,U,2),9)_" "_$$PAD^ORCHTAB($PIECE(ORZ,U,3),3)_$$PAD^ORCHTAB($PIECE(ORZ,U,4),11)_$$PAD^ORCHTAB($PIECE(ORZ,U,5),10)_$$DATETIME^ORCHTAB(ORTDT)_" "_$$PAD^ORCHTAB($PIECE(ORZ,U,16),
- 15)_...
- ... $PIECE(ORZ,U,6)
- +10 ;ck for comments
- SET ORHDR=1
- SET OROOT=$PIECE(ORTMP,",",1,5)_",""N"""
- +11 FOR
- SET ORTMP=$QUERY(@ORTMP)
- if $PIECE(ORTMP,",",1,6)'=OROOT
- QUIT
- WRITE !," "_@ORTMP
- End DoDot:1
- +12 if $GET(ORHDR)
- WRITE !
- KILL ^TMP("LRRR",$JOB)
- +13 WRITE !!,"NOTE: The nursing blood administration order must be entered separately."
- +14 QUIT
- +15 ;
- FIRST(DFN,TEST) ; -- returns array reference to first data node
- +1 ; in ^TMP("LRRR",$J,DFN) for TEST
- +2 NEW Y,IDT,DA
- SET Y=""
- +3 SET IDT=0
- FOR
- SET IDT=$ORDER(^TMP("LRRR",$JOB,DFN,"CH",IDT))
- if IDT<1
- QUIT
- Begin DoDot:1
- +4 SET DA=0
- FOR
- SET DA=$ORDER(^TMP("LRRR",$JOB,DFN,"CH",IDT,DA))
- if DA<1
- QUIT
- IF +$GET(^(DA))=TEST
- SET Y=1
- QUIT
- End DoDot:1
- if Y
- QUIT
- +5 IF Y
- SET Y=$NAME(^TMP("LRRR",$JOB,DFN,"CH",IDT,DA))
- +6 QUIT Y
- +7 ;
- ADDTAS ; -- adds T&S to order, sets ORTAS=1
- +1 ; Expects PROMPT=OI, ORTEST
- +2 NEW ORI
- SET ORI=$ORDER(ORDIALOG(PROMPT,"?"),-1)
- SET ORI=ORI+1
- +3 SET ORDIALOG(PROMPT,ORI)=+$ORDER(^ORD(101.43,"ID","1;99VBC",0))
- +4 WRITE !!,"Type & Screen added for new specimen."
- +5 SET ORTAS=1
- SET ORTEST=$GET(ORTEST)_$SELECT($LENGTH($GET(ORTEST)):U,1:"")_"1"
- +6 QUIT
- +7 ;
- CHANGED ; -- Kill dependent values when Component changes
- +1 NEW PTR,I,J
- +2 FOR I="FREE TEXT","RESULTS"
- SET PTR=$$PTR(I)
- IF PTR
- Begin DoDot:1
- +3 SET J=0
- FOR
- SET J=$ORDER(ORDIALOG(PTR,J))
- if J<1
- QUIT
- KILL ORDIALOG(PTR,J)
- +4 KILL ORDIALOG(PTR,"LIST")
- End DoDot:1
- +5 QUIT
- +6 ;
- DTW ; -- Comp D/T Wanted to specimen exp d/t for TAS [DTW Exit Action]
- +1 if '$GET(ORVB("SPECIMEN"))
- QUIT
- if $GET(ORTYPE)="Z"
- QUIT
- +2 NEW X,Y,%DT,EXP,OK
- +3 SET X=$GET(ORDIALOG(PROMPT,INST))
- SET %DT="T"
- DO ^%DT
- if Y<1
- QUIT
- +4 SET EXP=$$HL7TFM^XLFDT(+$GET(ORVB("SPECIMEN")))
- SET OK=1
- +5 IF EXP<Y
- if '$GET(ORTAS)
- DO ADDTAS
- SET OK=0
- +6 ;[re]set Specimen UID
- DO UID(OK)
- +7 QUIT
- +8 ;
- UID(OK) ; -- [re]set the Specimen UID if DTW changes
- +1 NEW SPCSTS,I,X
- +2 SET SPCSTS=$$PTR("SPECIMEN STATUS")
- +3 SET I=0
- FOR
- SET I=$ORDER(ORDIALOG(SPCSTS,I))
- if I<1
- QUIT
- Begin DoDot:1
- +4 SET X=$PIECE(ORDIALOG(SPCSTS,I),U)_U_$SELECT($GET(OK):$GET(ORVB("SPECIMEN")),1:"^")
- +5 SET ORDIALOG(SPCSTS,I)=X
- End DoDot:1
- +6 QUIT
- +7 ;
- REASON ; -- get allowable reasons
- +1 if $GET(ORDIALOG(PROMPT,"LIST"))
- QUIT
- NEW ORX,I,X
- +2 DO GETLST^XPAR(.ORX,"ALL","OR VBECS REASON FOR REQUEST","Q")
- +3 SET I=0
- FOR
- SET I=$ORDER(ORX(I))
- if I<1
- QUIT
- Begin DoDot:1
- +4 SET X=$PIECE($GET(ORX(I)),U,2)
- if '$LENGTH(X)
- QUIT
- +5 SET ORDIALOG(PROMPT,"LIST",I)=X_U_X
- +6 SET ORDIALOG(PROMPT,"LIST","B",$$UP^XLFSTR(X))=X
- End DoDot:1
- +7 ;_"^1"
- if ORX
- SET ORDIALOG(PROMPT,"LIST")=ORX
- +8 QUIT
- +9 ;
- ENTYPE ; -- set up Coll Type
- +1 IF '$DATA(ORTEST("Lab CollSamp"))
- Begin DoDot:1
- +2 NEW I,V,T,LC
- SET LC=1
- +3 ;no LC samp
- FOR I=1:1:$LENGTH(ORTEST,U)
- SET V=+$PIECE(ORTEST,U,I)
- Begin DoDot:2
- +4 ;VBECS ID -> #60 ien
- SET T=$$LAB60(V)
- +5 IF '$PIECE($GET(^LAB(60,T,0)),U,9)
- SET LC=0
- QUIT
- End DoDot:2
- if 'LC
- QUIT
- +6 SET ORTEST("Lab CollSamp")=LC
- End DoDot:1
- +7 IF '$DATA(ORTIME)
- IF '$DATA(ORIMTIME)
- DO GETIMES^ORCDLR1
- +8 QUIT
- +9 ;
- LAB60(X) ; -- Return file 60 ien for VBECS OI ID
- +1 NEW Y,I,NM
- +2 SET I=$ORDER(^ORD(101.43,"ID",+X_";99VBC",0))
- SET NM=$PIECE($GET(^ORD(101.43,+I,0)),U)_" - LAB"
- +3 SET Y=+$ORDER(^LAB(60,"B",NM,0))
- +4 QUIT Y
- +5 ;
- ENSURG ; -- Get list of surgeries from ORVB("SURGERY")
- +1 if $PIECE($GET(^ORD(101.42,+$$VAL^ORCD("URGENCY"),0)),U,2)="P"
- SET REQD=1
- +2 if $GET(ORDIALOG(PROMPT,"LIST"))
- QUIT
- KILL ORSURG
- +3 NEW I,CNT,X
- SET (I,CNT)=0
- +4 FOR
- SET I=$ORDER(ORVB("SURGERY",I))
- if I'>0
- QUIT
- SET X=$GET(ORVB("SURGERY",I))
- Begin DoDot:1
- +5 ;ORSURG(name)=NoBloodReqd
- SET ORSURG($PIECE(X,U))=$PIECE(X,U,2)
- SET X=$PIECE(X,U)
- +6 SET CNT=CNT+1
- SET ORDIALOG(PROMPT,"LIST",CNT)=X_U_X
- +7 SET ORDIALOG(PROMPT,"LIST","B",$$UP^XLFSTR(X))=X
- End DoDot:1
- +8 if CNT
- SET ORDIALOG(PROMPT,"LIST")=CNT_"^1"
- +9 QUIT
- +10 ;
- CKMSBOS ; -- check if MSBOS limit exists, was exceeded [from PSA]
- +1 if '$LENGTH($GET(Y))
- QUIT
- NEW OI,AMT,I,X,COMP,LIMIT
- +2 IF ORCOMP
- IF $GET(ORSURG($PIECE(Y,U)))
- WRITE !," >> No blood is required for this procedure!",!
- QUIT
- +3 SET OI=$$PTR("ORDERABLE ITEM")
- SET AMT=$$PTR("AMOUNT")
- +4 SET I=0
- FOR
- SET I=$ORDER(ORDIALOG(OI,I))
- if I<1
- QUIT
- Begin DoDot:1
- +5 SET X=ORDIALOG(OI,I)
- SET COMP=+$PIECE($GET(^ORD(101.43,+X,0)),U,2)
- +6 SET LIMIT=$GET(ORMSBOS(COMP,$PIECE(Y,U)))
- if LIMIT=""
- QUIT
- +7 if $GET(ORDIALOG(AMT,I))'>LIMIT
- QUIT
- +8 WRITE !," >> Requested #units of "_$PIECE($GET(^ORD(101.43,+X,0)),U)_" exceeds MSBOS limit of "_LIMIT_"!",!
- End DoDot:1
- +9 QUIT
- +10 ;
- ENURG ; -- Get list of urgencies from #101.42, parameter
- +1 if $GET(ORDIALOG(PROMPT,"LIST"))
- QUIT
- NEW I,CNT,X
- SET CNT=0
- +2 SET X=""
- FOR
- SET X=$ORDER(^ORD(101.42,"S.VBEC",X))
- if X=""
- QUIT
- Begin DoDot:1
- +3 ;I X="STAT" Q:'$$GET^XPAR("ALL","OR VBECS STAT USER")
- +4 ;I X="STAT",'$D(^XUSEC("ORES",DUZ)),'$D(^XUSEC("ORELSE",DUZ)) Q
- +5 SET I=0
- FOR
- SET I=$ORDER(^ORD(101.42,"S.VBEC",X,I))
- if I<1
- QUIT
- Begin DoDot:2
- +6 SET CNT=CNT+1
- SET ORDIALOG(PROMPT,"LIST",CNT)=I_U_X
- +7 SET ORDIALOG(PROMPT,"LIST","B",$$UP^XLFSTR(X))=I
- End DoDot:2
- End DoDot:1
- +8 if CNT
- SET ORDIALOG(PROMPT,"LIST")=CNT_"^1"
- +9 QUIT
- +10 ;
- ASKURG() ; -- ask unless PreOp, set default
- +1 NEW Y
- SET Y=1
- +2 IF FIRST
- IF '$DATA(ORDIALOG(PROMPT,INST))
- IF $GET(ORTYPE)'="Z"
- Begin DoDot:1
- +3 IF $$PREOP
- SET ORDIALOG(PROMPT,INST)=+$ORDER(^ORD(101.42,"C","P",0))
- SET Y=0
- QUIT
- +4 ;default
- SET ORDIALOG(PROMPT,INST)=9
- End DoDot:1
- +5 QUIT Y
- +6 ;
- PREOP() ; -- Returns 1 or 0, if order is for pre-op
- +1 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
- +2 SET DIR(0)="YAO"
- SET DIR("A")="Is this order for pre-op? "
- +3 SET DIR("?")="If YES, the urgency will be set to PRE-OP and a surgery name will be required"
- +4 SET DIR("B")="NO"
- DO ^DIR
- if $DATA(DTOUT)!($DATA(DUOUT))
- SET ORQUIT=1
- +5 QUIT +Y