Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ORWDPS32

ORWDPS32.m

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