- ORWDPS32 ; SLC/KCM - Pharmacy Calls for GUI Dialog ;08/23/17 12:00
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,94,190,195,237,243,350,397**;Dec 17, 1997;Build 22
- ;Per VHA Directive 6402, this routine should not be modified.
- ;
- ;
- ;
- NXT() ; -- ret next available index in data array
- S ILST=ILST+1
- Q ILST
- ;
- DLGSLCT(LST,PSTYPE,DFN,LOCIEN) ; return def lists for dialog
- ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpt)
- N ILST S ILST=0
- I PSTYPE="F" D Q ; IV Fluids
- . S LST($$NXT)="~ShortList" D SHORT
- . S LST($$NXT)="~Priorities" D PRIOR
- . ;S LST($$NXT)="~Schedules" D SCHED(LOCIEN)
- . S LST($$NXT)="~Route" D IVROUTE
- ;
- S LST($$NXT)="~ShortList" D SHORT ; Unit Dose & Outpt
- ;S LST($$NXT)="~Schedules" D SCHED(LOCIEN)
- S LST($$NXT)="~Priorities" D PRIOR
- I PSTYPE="O" D ; Outpt
- . S LST($$NXT)="~Pickup" D PICKUP
- . S LST($$NXT)="~SCStatus" D SCLIST
- Q
- SHORT ; from DLGSLCT, get short list of med quick orders
- ; !!! change this so that it uses the ORWDXQ call!!!
- N I,X,TMP
- I PSTYPE="U" S X="UD RX"
- I PSTYPE="F" S X="IV RX"
- I PSTYPE="O" S X="O RX"
- D GETQLST^ORWDXQ(.TMP,X,"iQ")
- S I=0 F S I=$O(TMP(I)) Q:'I S LST($$NXT)=TMP(I)
- Q
- SCHEDA ; (similar to SCHED, but also rtns admin times)
- N X,IEN,SCH,TIME
- K ^TMP($J,"ORWDPS32 SCHEDA")
- D AP^PSS51P1("PSJ",,,,"ORWDPS32 SCHEDA")
- S SCH="" F S SCH=$O(^TMP($J,"ORWDPS32 SCHEDA","APPSJ",SCH)) Q:SCH="" D
- .S IEN="" F S IEN=$O(^TMP($J,"ORWDPS32 SCHEDA","APPSJ",SCH,IEN)) Q:IEN'>0 D
- ..S TIME=$G(^TMP($J,"ORWDPS32 SCHEDA",IEN,1))
- ..S X=$S($L(TIME):" ("_TIME_")",1:"")
- ..S LST($$NXT)="i"_IEN_U_SCH_U_X
- K ^TMP($J,"ORWDPS32 SCHEDA")
- Q
- ;
- IVROUTE ;
- N ABB,EXP,IEN,RTE
- K ^TMP($J,"ORWDPS32 IVROUTE")
- D ALL^PSS51P2(,"??",,1,"ORWDPS32 IVROUTE")
- S RTE="" F S RTE=$O(^TMP($J,"ORWDPS32 IVROUTE","B",RTE)) Q:RTE="" D
- .S IEN=$O(^TMP($J,"ORWDPS32 IVROUTE","IV",RTE,"")) Q:IEN'>0
- .S ABB=$G(^TMP($J,"ORWDPS32 IVROUTE",IEN,1))
- .S EXP=$G(^TMP($J,"ORWDPS32 IVROUTE",IEN,4))
- .S LST($$NXT)="i"_IEN_U_RTE_U_ABB_U_EXP
- K ^TMP($J,"ORWDPS32 IVROUTE")
- Q
- ;
- ALLIVRTE(LST) ;
- N ABB,CNT,EXP,IEN,RTE
- K ^TMP($J,"ORWDPS32 ALLIVRTE")
- S CNT=0
- D ALL^PSS51P2(,"??",,1,"ORWDPS32 ALLIVRTE")
- S RTE="" F S RTE=$O(^TMP($J,"ORWDPS32 ALLIVRTE","B",RTE)) Q:RTE="" D
- .S IEN=$O(^TMP($J,"ORWDPS32 ALLIVRTE","IV",RTE,"")) Q:IEN'>0
- .S ABB=$G(^TMP($J,"ORWDPS32 ALLIVRTE",IEN,1))
- .S EXP=$G(^TMP($J,"ORWDPS32 ALLIVRTE",IEN,4))
- .S CNT=CNT+1,LST(CNT)=IEN_U_RTE_U_ABB_U_U_U_U
- K ^TMP($J,"ORWDPS32 IVROUTE")
- Q
- ;
- ROUTE ; from OISLCT^ORWDPS32, get list of routes for the drug form
- ; ** NEED BOTH ABBREVIATION & NAME IN LIST BOX
- N I,CNT,ABBR,IEN,ROUT,X
- S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D
- . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3)
- . S LST($$NXT)="i"_IEN_U_ROUT_U_ABBR
- . I I=1,IEN S LST($$NXT)="d"_IEN_U_ROUT ;_U_ABBR ; assume first always default
- S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D
- . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3)
- . I $L(ABBR),(ABBR'=ROUT) S LST($$NXT)="i"_IEN_U_ABBR_" ("_ROUT_")"_U_ABBR
- Q
- ;similar to SCHED^ORWDPS32, also returns Admin Time for Patient ward location
- ;AGP CPRS 27.72 THIS CODE IS NOT NEEDED ANYMORE
- SCHED(LOCIEN) ;
- N CNT,ORARRAY,SCH,IEN,EXP,TIME,TYP,X0,WIEN
- ;K ^TMP($J,"ORWDPS32 SCHED1")
- S WIEN=$$WARDIEN(+LOCIEN)
- D SCHED^PSS51P1(WIEN,.ORARRAY)
- S CNT=0 F S CNT=$O(ORARRAY(CNT)) Q:CNT'>0 D
- .S LST($$NXT)="i"_$P(ORARRAY(CNT),U,2,5)
- Q
- ;
- WARDIEN(LOCIEN) ;
- N RESULT
- S RESULT=0
- I LOCIEN=0 Q RESULT
- I $P($G(^SC(LOCIEN,42)),U)="" Q RESULT
- S RESULT=+$P($G(^SC(LOCIEN,42)),U)
- Q RESULT
- PRIOR ; from DLGSLCT, get list of allowed priorities
- N X,XREF
- S XREF=$S(PSTYPE="O":"S.PSO",1:"S.PSJ")
- S X="" F S X=$O(^ORD(101.42,XREF,X)) Q:'$L(X) D
- . S LST($$NXT)="i"_$O(^ORD(101.42,XREF,X,0))_U_X
- S LST($$NXT)="d"_$O(^ORD(101.42,"B","ROUTINE",0))_U_"ROUTINE"
- Q
- PICKUP ; from DLGSLCT, get prescription routing
- N X,EDITONLY
- F X="W^at Window","M^by Mail","C^in Clinic" S LST($$NXT)="i"_X
- S X=$$DEFPICK I $L(X) S LST($$NXT)="d"_X
- Q
- DEFPICK() ; ret def routing
- N X,DLG,PRMT
- S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X=""
- S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0))
- I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1)
- I X'="" S EDITONLY=1 Q X ; EDITONLY used by def action
- ;
- S X=$$GET^XPAR("ALL","ORWDPS ROUTING DEFAULT",1,"I")
- I X="C" S X="C^in Clinic" G XPICK
- I X="M" S X="M^by Mail" G XPICK
- I X="W" S X="W^at Window" G XPICK
- I X="N" S X="" G XPICK
- I X="" S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window")
- XPICK Q X
- ;
- SCLIST ; from DLGSLCT, get options for service connected
- F X="0^No","1^Yes" S LST($$NXT)="i"_X
- Q
- ;
- OISLCT(LST,OI,PSTYPE,ORVP) ; rtn for defaults for pharm OI
- N ILST S ILST=0
- K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
- S LST($$NXT)="~Dispense" D DISPDRG
- S LST($$NXT)="~Instruct" D INSTRCT
- S LST($$NXT)="~Route" D ROUTE
- S LST($$NXT)="~Message" D MESSAGE
- I $L($G(^TMP("PSJSCH",$J))) S LST($$NXT)="~DefSched",LST($$NXT)="d"_^($J)
- K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
- Q
- ;
- DISPDRUG(LST,OI) ; list dispense drugs for an OI
- N ILST,PSTYPE S ILST=0,PSTYPE="U" D DISPDRG
- Q
- ;
- DISPDRG ; from OISLCT, get disp drugs for this pharm OI
- N I,ORTMP,ORX
- S ORX=$T(ENDD^PSJORUTL),ORX=$L($P(ORX,";"),",")
- I ORX>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP,+ORVP)
- I ORX'>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP)
- S I="" F S I=$O(ORTMP(I)) Q:I="" D
- . I $P(ORTMP(I),U,4)="1" S $P(ORTMP(I),U,4)="NF"
- . S $P(ORTMP(I),U,3)="$"_$P(ORTMP(I),U,3)_" per "_$P(ORTMP(I),U,5)
- . S LST($$NXT)="i"_ORTMP(I)
- Q
- INSTRCT ; from OISLCT, get list of potential instructs (based on drug form)
- N INOUN,NOUN,IINS,INS,VERB,INSREC
- D START^PSSJORDF(+$P(^ORD(101.43,OI,0),U,2))
- I PSTYPE="U" Q ; don't use the instructions list for inpatients
- S IINS=0 F S IINS=$O(^TMP("PSJINS",$J,IINS)) Q:'IINS D
- . S INSREC=$G(^TMP("PSJINS",$J,IINS))
- . I '$D(VERB) S VERB=$P(INSREC,U)
- . I $L($P(INSREC,U,2)) S LST($$NXT)="i"_$P(INSREC,U,2)
- S LST($$NXT)="~Nouns"
- S INOUN=0 F S INOUN=$O(^TMP("PSJNOUN",$J,INOUN)) Q:'INOUN D
- . S LST($$NXT)="i"_$P(^TMP("PSJNOUN",$J,INOUN),U)
- I $D(VERB) S LST($$NXT)="~Verb",LST($$NXT)="d"_VERB
- ;
- Q
- MIXED(X) ; Return mixed case
- Q X
- ;
- MESSAGE ; message
- S I=0 F S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0 S LST($$NXT)="t"_^(I,0)
- Q
- ALLROUTE(LST) ; returns a list of all available med routes
- N I,X,ILST
- S ILST=0
- K ^TMP($J,"ORWDPS32 ALLROUTE")
- D ALL^PSS51P2(,"??",,,"ORWDPS32 ALLROUTE")
- S I=0 F S I=$O(^TMP($J,"ORWDPS32 ALLROUTE",I)) Q:'I D
- . I +$P(^TMP($J,"ORWDPS32 ALLROUTE",I,3),U)>0 S LST($$NXT)=I_U_^TMP($J,"ORWDPS32 ALLROUTE",I,.01)_U_^TMP($J,"ORWDPS32 ALLROUTE",I,1)
- K ^TMP($J,"ORWDPS32 ALLROUTE")
- Q
- VALROUTE(REC,X) ; validates route name & returns IEN + abbreviation
- N ABBR,NAME,IEN
- K ^TMP($J,"ORWDPS32 VALROUTE")
- S X=$$UPPER(X)
- D ALL^PSS51P2(,X,,1,"ORWDPS32 VALROUTE")
- I $P(^TMP($J,"ORWDPS32 VALROUTE",0),U)=-1 K ^TMP($J,"ORWDPS32 VALROUTE") S REC=0 Q
- S IEN=$O(^TMP($J,"ORWDPS32 VALROUTE","B",X,""))
- I IEN'>0 S IEN=$O(^TMP($J,"ORWDPS32 VALROUTE","C",X,""))
- I IEN'>0 S REC=0 Q
- S NAME=$G(^TMP($J,"ORWDPS32 VALROUTE",IEN,.01))
- S ABBR=$G(^TMP($J,"ORWDPS32 VALROUTE",IEN,1))
- I '$L(ABBR) S ABBR=NAME
- I ($$UPPER(NAME)'=X),($$UPPER(ABBR)'=X) S REC=0 K ^TMP($J,"ORWDPS32 VALROUTE") Q
- S REC=IEN_U_ABBR
- K ^TMP($J,"ORWDPS32 VALROUTE")
- Q
- AUTH(VAL,PRV,ORDLOG) ; For inpatient meds, check restrictions
- N NAME,AUTH,INACT,X,ORSDLOG,ORDL,A,IFN,B
- S VAL=0
- S NAME=$P($G(^VA(200,PRV,20)),U,2) S:'$L(NAME) NAME=$P(^(0),U)
- S X=$G(^VA(200,PRV,"PS")),AUTH=$P(X,U),INACT=$P(X,U,4)
- S ORDLOG=$G(ORDLOG),ORDL=""
- I ORDLOG?1"X".E S IFN=$E(ORDLOG,2,99),A=$P($G(^OR(100,+IFN,0)),"^",5) D
- . I $P(A,";",2)[101.41 S ORDLOG=+A Q
- . S ORDLOG=""
- I ORDLOG]"" S A=$G(^ORD(101.41,ORDLOG,0)) I $P(A,"^",4)="Q" S B=$P(A,"^",5) I B]"" S ORDL=$P($G(^ORD(100.98,B,0)),"^",4)
- S ORSDLOG=$O(^ORD(101.41,"B","PSO SUPPLY",""))
- I 'AUTH!(INACT&(DT>INACT)) D Q:VAL
- . I (ORDLOG=ORSDLOG!(ORDL=ORSDLOG)),$D(^XUSEC("ORSUPPLY",DUZ)) Q
- . S VAL="1^"_NAME_" is not authorized to write medication orders."
- I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS MED ORDERS") D Q
- . S VAL="1^OREMAS key holders may not enter medication orders."
- Q
- ;
- AUTHNVA(VAL,PRV) ; For Non-VA meds, check restrictions
- N NAME,AUTH,INACT,X S VAL=0
- I $D(^XUSEC("OREMAS",DUZ)),$$GET^XPAR("ALL","OR OREMAS NON-VA MED ORDERS")=2 Q
- I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS NON-VA MED ORDERS") D Q
- . S VAL="1^OREMAS key holders may not enter non-VA medication orders."
- S NAME=$P($G(^VA(200,PRV,20)),U,2) S:'$L(NAME) NAME=$P(^(0),U)
- S X=$G(^VA(200,PRV,"PS")),AUTH=$P(X,U),INACT=$P(X,U,4)
- I 'AUTH!(INACT&(DT>INACT)) D Q
- . S VAL="1^"_NAME_" is not authorized to write medication orders."
- Q
- ;
- UPPER(X) ; return uppercase
- Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- ;
- TRIM(X) ; trim leading and trailing spaces
- S X=$RE(X) F S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" " Q:'$L(X) ;trail
- S X=$RE(X) F S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" " Q:'$L(X) ;lead
- Q X
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWDPS32 9425 printed Jan 18, 2025@03:36:52 Page 2
- ORWDPS32 ; SLC/KCM - Pharmacy Calls for GUI Dialog ;08/23/17 12:00
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,94,190,195,237,243,350,397**;Dec 17, 1997;Build 22
- +2 ;Per VHA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ;
- +5 ;
- NXT() ; -- ret next available index in data array
- +1 SET ILST=ILST+1
- +2 QUIT ILST
- +3 ;
- DLGSLCT(LST,PSTYPE,DFN,LOCIEN) ; return def lists for dialog
- +1 ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpt)
- +2 NEW ILST
- SET ILST=0
- +3 ; IV Fluids
- IF PSTYPE="F"
- Begin DoDot:1
- +4 SET LST($$NXT)="~ShortList"
- DO SHORT
- +5 SET LST($$NXT)="~Priorities"
- DO PRIOR
- +6 ;S LST($$NXT)="~Schedules" D SCHED(LOCIEN)
- +7 SET LST($$NXT)="~Route"
- DO IVROUTE
- End DoDot:1
- QUIT
- +8 ;
- +9 ; Unit Dose & Outpt
- SET LST($$NXT)="~ShortList"
- DO SHORT
- +10 ;S LST($$NXT)="~Schedules" D SCHED(LOCIEN)
- +11 SET LST($$NXT)="~Priorities"
- DO PRIOR
- +12 ; Outpt
- IF PSTYPE="O"
- Begin DoDot:1
- +13 SET LST($$NXT)="~Pickup"
- DO PICKUP
- +14 SET LST($$NXT)="~SCStatus"
- DO SCLIST
- End DoDot:1
- +15 QUIT
- SHORT ; from DLGSLCT, get short list of med quick orders
- +1 ; !!! change this so that it uses the ORWDXQ call!!!
- +2 NEW I,X,TMP
- +3 IF PSTYPE="U"
- SET X="UD RX"
- +4 IF PSTYPE="F"
- SET X="IV RX"
- +5 IF PSTYPE="O"
- SET X="O RX"
- +6 DO GETQLST^ORWDXQ(.TMP,X,"iQ")
- +7 SET I=0
- FOR
- SET I=$ORDER(TMP(I))
- if 'I
- QUIT
- SET LST($$NXT)=TMP(I)
- +8 QUIT
- SCHEDA ; (similar to SCHED, but also rtns admin times)
- +1 NEW X,IEN,SCH,TIME
- +2 KILL ^TMP($JOB,"ORWDPS32 SCHEDA")
- +3 DO AP^PSS51P1("PSJ",,,,"ORWDPS32 SCHEDA")
- +4 SET SCH=""
- FOR
- SET SCH=$ORDER(^TMP($JOB,"ORWDPS32 SCHEDA","APPSJ",SCH))
- if SCH=""
- QUIT
- Begin DoDot:1
- +5 SET IEN=""
- FOR
- SET IEN=$ORDER(^TMP($JOB,"ORWDPS32 SCHEDA","APPSJ",SCH,IEN))
- if IEN'>0
- QUIT
- Begin DoDot:2
- +6 SET TIME=$GET(^TMP($JOB,"ORWDPS32 SCHEDA",IEN,1))
- +7 SET X=$SELECT($LENGTH(TIME):" ("_TIME_")",1:"")
- +8 SET LST($$NXT)="i"_IEN_U_SCH_U_X
- End DoDot:2
- End DoDot:1
- +9 KILL ^TMP($JOB,"ORWDPS32 SCHEDA")
- +10 QUIT
- +11 ;
- IVROUTE ;
- +1 NEW ABB,EXP,IEN,RTE
- +2 KILL ^TMP($JOB,"ORWDPS32 IVROUTE")
- +3 DO ALL^PSS51P2(,"??",,1,"ORWDPS32 IVROUTE")
- +4 SET RTE=""
- FOR
- SET RTE=$ORDER(^TMP($JOB,"ORWDPS32 IVROUTE","B",RTE))
- if RTE=""
- QUIT
- Begin DoDot:1
- +5 SET IEN=$ORDER(^TMP($JOB,"ORWDPS32 IVROUTE","IV",RTE,""))
- if IEN'>0
- QUIT
- +6 SET ABB=$GET(^TMP($JOB,"ORWDPS32 IVROUTE",IEN,1))
- +7 SET EXP=$GET(^TMP($JOB,"ORWDPS32 IVROUTE",IEN,4))
- +8 SET LST($$NXT)="i"_IEN_U_RTE_U_ABB_U_EXP
- End DoDot:1
- +9 KILL ^TMP($JOB,"ORWDPS32 IVROUTE")
- +10 QUIT
- +11 ;
- ALLIVRTE(LST) ;
- +1 NEW ABB,CNT,EXP,IEN,RTE
- +2 KILL ^TMP($JOB,"ORWDPS32 ALLIVRTE")
- +3 SET CNT=0
- +4 DO ALL^PSS51P2(,"??",,1,"ORWDPS32 ALLIVRTE")
- +5 SET RTE=""
- FOR
- SET RTE=$ORDER(^TMP($JOB,"ORWDPS32 ALLIVRTE","B",RTE))
- if RTE=""
- QUIT
- Begin DoDot:1
- +6 SET IEN=$ORDER(^TMP($JOB,"ORWDPS32 ALLIVRTE","IV",RTE,""))
- if IEN'>0
- QUIT
- +7 SET ABB=$GET(^TMP($JOB,"ORWDPS32 ALLIVRTE",IEN,1))
- +8 SET EXP=$GET(^TMP($JOB,"ORWDPS32 ALLIVRTE",IEN,4))
- +9 SET CNT=CNT+1
- SET LST(CNT)=IEN_U_RTE_U_ABB_U_U_U_U
- End DoDot:1
- +10 KILL ^TMP($JOB,"ORWDPS32 IVROUTE")
- +11 QUIT
- +12 ;
- ROUTE ; from OISLCT^ORWDPS32, get list of routes for the drug form
- +1 ; ** NEED BOTH ABBREVIATION & NAME IN LIST BOX
- +2 NEW I,CNT,ABBR,IEN,ROUT,X
- +3 SET I=""
- FOR
- SET I=$ORDER(^TMP("PSJMR",$JOB,I))
- if I=""
- QUIT
- Begin DoDot:1
- +4 SET ROUT=$PIECE(^TMP("PSJMR",$JOB,I),U)
- SET ABBR=$PIECE(^(I),U,2)
- SET IEN=$PIECE(^(I),U,3)
- +5 SET LST($$NXT)="i"_IEN_U_ROUT_U_ABBR
- +6 ;_U_ABBR ; assume first always default
- IF I=1
- IF IEN
- SET LST($$NXT)="d"_IEN_U_ROUT
- End DoDot:1
- +7 SET I=""
- FOR
- SET I=$ORDER(^TMP("PSJMR",$JOB,I))
- if I=""
- QUIT
- Begin DoDot:1
- +8 SET ROUT=$PIECE(^TMP("PSJMR",$JOB,I),U)
- SET ABBR=$PIECE(^(I),U,2)
- SET IEN=$PIECE(^(I),U,3)
- +9 IF $LENGTH(ABBR)
- IF (ABBR'=ROUT)
- SET LST($$NXT)="i"_IEN_U_ABBR_" ("_ROUT_")"_U_ABBR
- End DoDot:1
- +10 QUIT
- +11 ;similar to SCHED^ORWDPS32, also returns Admin Time for Patient ward location
- +12 ;AGP CPRS 27.72 THIS CODE IS NOT NEEDED ANYMORE
- SCHED(LOCIEN) ;
- +1 NEW CNT,ORARRAY,SCH,IEN,EXP,TIME,TYP,X0,WIEN
- +2 ;K ^TMP($J,"ORWDPS32 SCHED1")
- +3 SET WIEN=$$WARDIEN(+LOCIEN)
- +4 DO SCHED^PSS51P1(WIEN,.ORARRAY)
- +5 SET CNT=0
- FOR
- SET CNT=$ORDER(ORARRAY(CNT))
- if CNT'>0
- QUIT
- Begin DoDot:1
- +6 SET LST($$NXT)="i"_$P(ORARRAY(CNT),U,2,5)
- End DoDot:1
- +7 QUIT
- +8 ;
- WARDIEN(LOCIEN) ;
- +1 NEW RESULT
- +2 SET RESULT=0
- +3 IF LOCIEN=0
- QUIT RESULT
- +4 IF $PIECE($GET(^SC(LOCIEN,42)),U)=""
- QUIT RESULT
- +5 SET RESULT=+$PIECE($GET(^SC(LOCIEN,42)),U)
- +6 QUIT RESULT
- PRIOR ; from DLGSLCT, get list of allowed priorities
- +1 NEW X,XREF
- +2 SET XREF=$SELECT(PSTYPE="O":"S.PSO",1:"S.PSJ")
- +3 SET X=""
- FOR
- SET X=$ORDER(^ORD(101.42,XREF,X))
- if '$LENGTH(X)
- QUIT
- Begin DoDot:1
- +4 SET LST($$NXT)="i"_$O(^ORD(101.42,XREF,X,0))_U_X
- End DoDot:1
- +5 SET LST($$NXT)="d"_$O(^ORD(101.42,"B","ROUTINE",0))_U_"ROUTINE"
- +6 QUIT
- PICKUP ; from DLGSLCT, get prescription routing
- +1 NEW X,EDITONLY
- +2 FOR X="W^at Window","M^by Mail","C^in Clinic"
- SET LST($$NXT)="i"_X
- +3 SET X=$$DEFPICK
- IF $LENGTH(X)
- SET LST($$NXT)="d"_X
- +4 QUIT
- DEFPICK() ; ret def routing
- +1 NEW X,DLG,PRMT
- +2 SET DLG=$ORDER(^ORD(101.41,"AB","PSO OERR",0))
- SET X=""
- +3 SET PRMT=$ORDER(^ORD(101.41,"AB","OR GTX ROUTING",0))
- +4 IF $DATA(^TMP("ORECALL",$JOB,+DLG,+PRMT,1))
- SET X=^(1)
- +5 ; EDITONLY used by def action
- IF X'=""
- SET EDITONLY=1
- QUIT X
- +6 ;
- +7 SET X=$$GET^XPAR("ALL","ORWDPS ROUTING DEFAULT",1,"I")
- +8 IF X="C"
- SET X="C^in Clinic"
- GOTO XPICK
- +9 IF X="M"
- SET X="M^by Mail"
- GOTO XPICK
- +10 IF X="W"
- SET X="W^at Window"
- GOTO XPICK
- +11 IF X="N"
- SET X=""
- GOTO XPICK
- +12 IF X=""
- SET X=$SELECT($DATA(^PSX(550,"C")):"M^by Mail",1:"W^at Window")
- XPICK QUIT X
- +1 ;
- SCLIST ; from DLGSLCT, get options for service connected
- +1 FOR X="0^No","1^Yes"
- SET LST($$NXT)="i"_X
- +2 QUIT
- +3 ;
- OISLCT(LST,OI,PSTYPE,ORVP) ; rtn for defaults for pharm OI
- +1 NEW ILST
- SET ILST=0
- +2 KILL ^TMP("PSJINS",$JOB),^TMP("PSJMR",$JOB),^TMP("PSJNOUN",$JOB),^TMP("PSJSCH",$JOB)
- +3 SET LST($$NXT)="~Dispense"
- DO DISPDRG
- +4 SET LST($$NXT)="~Instruct"
- DO INSTRCT
- +5 SET LST($$NXT)="~Route"
- DO ROUTE
- +6 SET LST($$NXT)="~Message"
- DO MESSAGE
- +7 IF $LENGTH($GET(^TMP("PSJSCH",$JOB)))
- SET LST($$NXT)="~DefSched"
- SET LST($$NXT)="d"_^($JOB)
- +8 KILL ^TMP("PSJINS",$JOB),^TMP("PSJMR",$JOB),^TMP("PSJNOUN",$JOB),^TMP("PSJSCH",$JOB)
- +9 QUIT
- +10 ;
- DISPDRUG(LST,OI) ; list dispense drugs for an OI
- +1 NEW ILST,PSTYPE
- SET ILST=0
- SET PSTYPE="U"
- DO DISPDRG
- +2 QUIT
- +3 ;
- DISPDRG ; from OISLCT, get disp drugs for this pharm OI
- +1 NEW I,ORTMP,ORX
- +2 SET ORX=$TEXT(ENDD^PSJORUTL)
- SET ORX=$LENGTH($PIECE(ORX,";"),",")
- +3 IF ORX>3
- DO ENDD^PSJORUTL("^^^"_+$PIECE($GET(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP,+ORVP)
- +4 IF ORX'>3
- DO ENDD^PSJORUTL("^^^"_+$PIECE($GET(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP)
- +5 SET I=""
- FOR
- SET I=$ORDER(ORTMP(I))
- if I=""
- QUIT
- Begin DoDot:1
- +6 IF $PIECE(ORTMP(I),U,4)="1"
- SET $PIECE(ORTMP(I),U,4)="NF"
- +7 SET $PIECE(ORTMP(I),U,3)="$"_$PIECE(ORTMP(I),U,3)_" per "_$PIECE(ORTMP(I),U,5)
- +8 SET LST($$NXT)="i"_ORTMP(I)
- End DoDot:1
- +9 QUIT
- INSTRCT ; from OISLCT, get list of potential instructs (based on drug form)
- +1 NEW INOUN,NOUN,IINS,INS,VERB,INSREC
- +2 DO START^PSSJORDF(+$PIECE(^ORD(101.43,OI,0),U,2))
- +3 ; don't use the instructions list for inpatients
- IF PSTYPE="U"
- QUIT
- +4 SET IINS=0
- FOR
- SET IINS=$ORDER(^TMP("PSJINS",$JOB,IINS))
- if 'IINS
- QUIT
- Begin DoDot:1
- +5 SET INSREC=$GET(^TMP("PSJINS",$JOB,IINS))
- +6 IF '$DATA(VERB)
- SET VERB=$PIECE(INSREC,U)
- +7 IF $LENGTH($PIECE(INSREC,U,2))
- SET LST($$NXT)="i"_$P(INSREC,U,2)
- End DoDot:1
- +8 SET LST($$NXT)="~Nouns"
- +9 SET INOUN=0
- FOR
- SET INOUN=$ORDER(^TMP("PSJNOUN",$JOB,INOUN))
- if 'INOUN
- QUIT
- Begin DoDot:1
- +10 SET LST($$NXT)="i"_$P(^TMP("PSJNOUN",$JOB,INOUN),U)
- End DoDot:1
- +11 IF $DATA(VERB)
- SET LST($$NXT)="~Verb"
- SET LST($$NXT)="d"_VERB
- +12 ;
- +13 QUIT
- MIXED(X) ; Return mixed case
- +1 QUIT X
- +2 ;
- MESSAGE ; message
- +1 SET I=0
- FOR
- SET I=$ORDER(^ORD(101.43,OI,8,I))
- if I'>0
- QUIT
- SET LST($$NXT)="t"_^(I,0)
- +2 QUIT
- ALLROUTE(LST) ; returns a list of all available med routes
- +1 NEW I,X,ILST
- +2 SET ILST=0
- +3 KILL ^TMP($JOB,"ORWDPS32 ALLROUTE")
- +4 DO ALL^PSS51P2(,"??",,,"ORWDPS32 ALLROUTE")
- +5 SET I=0
- FOR
- SET I=$ORDER(^TMP($JOB,"ORWDPS32 ALLROUTE",I))
- if 'I
- QUIT
- Begin DoDot:1
- +6 IF +$PIECE(^TMP($JOB,"ORWDPS32 ALLROUTE",I,3),U)>0
- SET LST($$NXT)=I_U_^TMP($JOB,"ORWDPS32 ALLROUTE",I,.01)_U_^TMP($JOB,"ORWDPS32 ALLROUTE",I,1)
- End DoDot:1
- +7 KILL ^TMP($JOB,"ORWDPS32 ALLROUTE")
- +8 QUIT
- VALROUTE(REC,X) ; validates route name & returns IEN + abbreviation
- +1 NEW ABBR,NAME,IEN
- +2 KILL ^TMP($JOB,"ORWDPS32 VALROUTE")
- +3 SET X=$$UPPER(X)
- +4 DO ALL^PSS51P2(,X,,1,"ORWDPS32 VALROUTE")
- +5 IF $PIECE(^TMP($JOB,"ORWDPS32 VALROUTE",0),U)=-1
- KILL ^TMP($JOB,"ORWDPS32 VALROUTE")
- SET REC=0
- QUIT
- +6 SET IEN=$ORDER(^TMP($JOB,"ORWDPS32 VALROUTE","B",X,""))
- +7 IF IEN'>0
- SET IEN=$ORDER(^TMP($JOB,"ORWDPS32 VALROUTE","C",X,""))
- +8 IF IEN'>0
- SET REC=0
- QUIT
- +9 SET NAME=$GET(^TMP($JOB,"ORWDPS32 VALROUTE",IEN,.01))
- +10 SET ABBR=$GET(^TMP($JOB,"ORWDPS32 VALROUTE",IEN,1))
- +11 IF '$LENGTH(ABBR)
- SET ABBR=NAME
- +12 IF ($$UPPER(NAME)'=X)
- IF ($$UPPER(ABBR)'=X)
- SET REC=0
- KILL ^TMP($JOB,"ORWDPS32 VALROUTE")
- QUIT
- +13 SET REC=IEN_U_ABBR
- +14 KILL ^TMP($JOB,"ORWDPS32 VALROUTE")
- +15 QUIT
- AUTH(VAL,PRV,ORDLOG) ; For inpatient meds, check restrictions
- +1 NEW NAME,AUTH,INACT,X,ORSDLOG,ORDL,A,IFN,B
- +2 SET VAL=0
- +3 SET NAME=$PIECE($GET(^VA(200,PRV,20)),U,2)
- if '$LENGTH(NAME)
- SET NAME=$PIECE(^(0),U)
- +4 SET X=$GET(^VA(200,PRV,"PS"))
- SET AUTH=$PIECE(X,U)
- SET INACT=$PIECE(X,U,4)
- +5 SET ORDLOG=$GET(ORDLOG)
- SET ORDL=""
- +6 IF ORDLOG?1"X".E
- SET IFN=$EXTRACT(ORDLOG,2,99)
- SET A=$PIECE($GET(^OR(100,+IFN,0)),"^",5)
- Begin DoDot:1
- +7 IF $PIECE(A,";",2)[101.41
- SET ORDLOG=+A
- QUIT
- +8 SET ORDLOG=""
- End DoDot:1
- +9 IF ORDLOG]""
- SET A=$GET(^ORD(101.41,ORDLOG,0))
- IF $PIECE(A,"^",4)="Q"
- SET B=$PIECE(A,"^",5)
- IF B]""
- SET ORDL=$PIECE($GET(^ORD(100.98,B,0)),"^",4)
- +10 SET ORSDLOG=$ORDER(^ORD(101.41,"B","PSO SUPPLY",""))
- +11 IF 'AUTH!(INACT&(DT>INACT))
- Begin DoDot:1
- +12 IF (ORDLOG=ORSDLOG!(ORDL=ORSDLOG))
- IF $DATA(^XUSEC("ORSUPPLY",DUZ))
- QUIT
- +13 SET VAL="1^"_NAME_" is not authorized to write medication orders."
- End DoDot:1
- if VAL
- QUIT
- +14 IF $DATA(^XUSEC("OREMAS",DUZ))
- IF '$$GET^XPAR("ALL","OR OREMAS MED ORDERS")
- Begin DoDot:1
- +15 SET VAL="1^OREMAS key holders may not enter medication orders."
- End DoDot:1
- QUIT
- +16 QUIT
- +17 ;
- AUTHNVA(VAL,PRV) ; For Non-VA meds, check restrictions
- +1 NEW NAME,AUTH,INACT,X
- SET VAL=0
- +2 IF $DATA(^XUSEC("OREMAS",DUZ))
- IF $$GET^XPAR("ALL","OR OREMAS NON-VA MED ORDERS")=2
- QUIT
- +3 IF $DATA(^XUSEC("OREMAS",DUZ))
- IF '$$GET^XPAR("ALL","OR OREMAS NON-VA MED ORDERS")
- Begin DoDot:1
- +4 SET VAL="1^OREMAS key holders may not enter non-VA medication orders."
- End DoDot:1
- QUIT
- +5 SET NAME=$PIECE($GET(^VA(200,PRV,20)),U,2)
- if '$LENGTH(NAME)
- SET NAME=$PIECE(^(0),U)
- +6 SET X=$GET(^VA(200,PRV,"PS"))
- SET AUTH=$PIECE(X,U)
- SET INACT=$PIECE(X,U,4)
- +7 IF 'AUTH!(INACT&(DT>INACT))
- Begin DoDot:1
- +8 SET VAL="1^"_NAME_" is not authorized to write medication orders."
- End DoDot:1
- QUIT
- +9 QUIT
- +10 ;
- UPPER(X) ; return uppercase
- +1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- +2 ;
- TRIM(X) ; trim leading and trailing spaces
- +1 ;trail
- SET X=$REVERSE(X)
- FOR
- if $EXTRACT(X)=" "
- SET X=$EXTRACT(X,2,999)
- if $EXTRACT(X)'=" "
- QUIT
- if '$LENGTH(X)
- QUIT
- +2 ;lead
- SET X=$REVERSE(X)
- FOR
- if $EXTRACT(X)=" "
- SET X=$EXTRACT(X,2,999)
- if $EXTRACT(X)'=" "
- QUIT
- if '$LENGTH(X)
- QUIT
- +3 QUIT X
- +4 ;