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

PSGOERS.m

Go to the documentation of this file.
  1. PSGOERS ;BIR/CML3 - RENEW SELECTED ORDERS ; 10/23/14 9:30pm
  1. ;;5.0;INPATIENT MEDICATIONS;**11,29,35,47,58,110,281,327**;16 DEC 97;Build 114
  1. ;
  1. ; Reference to ^PS(50.7 is supported by DBIA 2180
  1. ; Reference to ^PS(55 is supported by DBIA 2191
  1. ; Reference to ^PSDRUG( is supported by DBIA 2192
  1. ; Reference to ^PSSLOCK is supported by DBIA 2789
  1. ; Reference to NOW^%DTC is supported by DBIA 10000
  1. ;
  1. MARK ; only mark order, not actually renew
  1. W !,"...marking ",PSGPDRGN," ",PSGDO,"..." S $P(^PS(55,PSGP,5,+PSGORD,4),"^",15,17)="1^"_DUZ_"^"_PSGDT,PSGAL("C")=13180 D ^PSGAL5 W "."
  1. I $D(PSJSYSO) S PSGPOSA="R",PSGPOSD=PSGDT,PSGORD=+PSGORD_"A" D ENPOS^PSGVDS
  1. Q
  1. RENEW ; mark or renew order
  1. D NOW^%DTC K DA S DA(1)=PSGP,DA=+PSGORD,PSGDT=+$E(%,1,12)
  1. I $G(PSGFD)="" S X=$P(PSGFDN,":",1,2) D ^%DT S:Y>0 PSGFD=Y
  1. ; do order checking
  1. N PSJABT,PSGDRG,PSGOER1,PSGDO,PSGPDRG,PSGPDRGN,PSGOER0,PSGST,PSGOER2,PSGSI,PSGOSD,PSGOFD,PSGNEDFD,PSGNESD,PSGMR,PSGSM,PSGHSM,PSGSCH,PSGS0Y,PSGS0XT,PSGNEFD
  1. ;* S PSGDRG=$P($G(^PS(55,PSGP,5,+PSGORD,1,1,0)),"^")
  1. ;* K PSGORQF D ENDDC^PSGSICHK(PSGP,+PSGDRG)
  1. ;D OC55^PSGOER
  1. ;I $D(PSGORQF) W !!," ",PSGOERS2,". ",$P($$DRUGNAME^PSJLMUTL(PSGP,PSGORD),"^")," ",$P(^PS(55,PSGP,5,+PSGORD,.2),"^",2),!,"...No action taken on this order...",! Q
  1. ;* Q:$D(PSGORQF) ; quit if not to continue
  1. ;
  1. S PSGOER1=$G(^PS(55,PSGP,5,+PSGORD,.2)),PSGDO=$P(PSGOER1,"^",2),PSGPDRG=$P(PSGOER1,"^"),PSGPDRGN=$$ENPDN^PSGMI(PSGPDRG) I '$P(PSJSYSP0,"^",3) G MARK
  1. S PSGOER0=$G(^PS(55,PSGP,5,+PSGORD,0)),PSGST=$P(PSGOER0,"^",7),PSGOER2=$G(^(2)),PSGND4=$G(^(4)),PSGSI=$G(^(6)),PSGOSD=$P(PSGOER2,"^",2),PSGOFD=$P(PSGOER2,"^",4),PSGNEDFD=$P($$GTNEDFD^PSGOE7("U",PSGPDRG),U)_"^^"_PSGST
  1. N PSGOEAV S PSGOEAV=1,PSGOORD=PSGORD W "." K ^PS(53.45,PSJSYSP,1),^(2)
  1. I $$CHKDD() W !!,"...",PSGPDRGN," ",PSGDO," order NOT renewed..." Q
  1. ; p327
  1. I $$ISCLOZ^PSJCLOZ(,,PSGP,+PSGORD) D Q
  1. .W !,"Clozapine orders cannot be renewed."
  1. .W !,"...order NOT renewed..."
  1. ;W !!,"...renewing ",PSGOERS2,". ",PSGPDRGN," ",PSGDO,"..."
  1. S PSGMR=$P(PSGOER0,"^",3),PSGMRN=$$ENMRN^PSGMI(PSGMR),PSGSM=$P(PSGOER0,"^",5),PSGHSM=$P(PSGOER0,"^",6),PSGPDRG=$P(PSGOER1,"^"),PSGDO=$P(PSGOER1,"^",2)
  1. S PSGSCH=$P(PSGOER2,"^"),PSGS0Y=$P(PSGOER2,"^",5),PSGS0XT=$P(PSGOER2,"^",6),PSGNESD=PSGSD,PSGNEFD=$S(PSGST="O":PSGSD,1:PSGFD)
  1. S:PSJPWD'=$P(PSGOER2,U,10) PSGS0Y=$$ENRNAT^PSGOU($P(PSGOER2,U,10),+PSJPWD,PSGSCH,PSGS0Y)
  1. ;K ^PS(53.45,PSJSYSP,4) S Q=0 F S Q=$O(^PS(55,PSGP,5,+PSGORD,12,Q)) Q:'Q S ^PS(53.45,PSJSYSP,4,Q,0)=$G(^(Q,0))
  1. I $O(^PS(55,PSGP,5,+PSGORD,3,0)) S ^PS(53.45,PSJSYSP,1,0)=^(0),Q=0 F S Q=$O(^PS(55,PSGP,5,+PSGORD,3,Q)) Q:'Q S ^PS(53.45,PSJSYSP,1,Q,0)=$G(^(Q,0))
  1. I '$O(^PS(53.45,PSJSYSP,2,0)) D
  1. .S X=$O(^PS(55,PSGP,5,+PSGORD,1,0)) I X S (Q,Q1)=0 F S Q=$O(^PS(55,PSGP,5,+PSGORD,1,Q)) Q:'Q S ND=$G(^(Q,0)) I ND,$S('$P(ND,"^",3):1,1:$P(ND,"^",3)>DT) S Q1=Q1+1,^PS(53.45,PSJSYSP,2,Q1,0)=$P(ND,"^",1,3)
  1. D NEWOC55^PSGOER I $G(PSGORQF) W !!,"...order NOT renewed..." Q
  1. W !!,"...renewing ",PSGOERS2,". ",PSGPDRGN," ",PSGDO,"..."
  1. D SPEED^PSGOER
  1. ; PSGP,PSGORD) D UPDREN(PSGORD,PSGDT,PSGOEPR,PSGOFD,PSJNOO),UPDRENOE(PSGP,PSGORD,PSGDT
  1. ;S:$S(X:Q1,1:0) ^PS(53.45,PSJSYSP,2,0)="^53.4502P^"_Q1_"^"_Q1 D ^PSGOETO I +PSJSYSU=3,PSGOORD["O" D EN^PSGPEN(+PSGORD)
  1. ;W !,"...updating original order...",! K DA S DA(1)=PSGP,DA=+PSGOORD,PSGAL("C")=PSJSYSU*10+18000 D ^PSGAL5
  1. ;I PSGORD'["O",PSGSD<PSGOFD S PSGALR=70,DIE="^PS(55,"_PSGP_",5,",DR="34////"_+PSGSD S:PSGSD'>PSGDT DR=DR_";28////E"
  1. ;I D ^DIE I $P($G(^PS(55,PSGP,5,+PSGOORD,0)),"^",21) D EN1^PSJHL2(PSGP,"SC",PSGOORD,"ORDER EXPIRED")
  1. ;S $P(PSGND4,"^",12,14)="^^",$P(PSGND4,"^",15,20)="^^^^^",$P(PSGND4,"^",22,24)="^^",^PS(55,PSGP,5,+PSGOORD,4)=PSGND4,$P(^(0),"^",26,27)=PSGORD_"^R"
  1. Q
  1. CHKDD() ;
  1. I '$$CHKDD^PSGOE2("^PS(55,"_PSGP_",5,"_+PSGORD_",") Q 0
  1. I $P(PSJSYSU,";")'=3,'$P(PSJSYSP0,U,2) W !!,"This order's dispense drug is invalid, a pharmacist must renew this order." Q 1
  1. W !!,"THE DISPENSE DRUG IS MISSING FROM THIS ORDER."
  1. D ENDRG^PSGOEF1(+^PS(55,PSGP,5,+PSGORD,.2),0)
  1. I $G(DUOUT) W !,"ORDER NOT RENEW."
  1. Q $G(DUOUT)!'$G(DRG)
  1. EN ;
  1. NEW PSGORQF,PSJOCFG S PSJOCFG="SPEED RENEW"
  1. Q:'$$HIDDEN^PSJLMUTL("SPEED") S PSJSPEED=1
  1. N PSGONR,CODE,ST,DRG,ON S PSGOEORF=1 D FULL^VALM1
  1. S CODE="",PSGONR=0 F S CODE=$O(^TMP("PSJ",$J,CODE)) Q:CODE'="A" D
  1. .S ST="" F S ST=$O(^TMP("PSJ",$J,CODE,ST)) Q:ST="" D
  1. ..S DRG="" F S DRG=$O(^TMP("PSJ",$J,CODE,ST,DRG)) Q:DRG="" S ON="" F S ON=$O(^TMP("PSJ",$J,CODE,ST,DRG,ON)) Q:ON="" S PSGONR=PSGONR+1
  1. S PSGONW="R",PSGLMT=PSGONR D ENWO^PSGON I "^"[X K X G DONE
  1. S PSGOSD=0 F PSGOERS=1:1:PSGODDD F PSGOERS1=1:1 S PSGOERS2=$P(PSGODDD(PSGOERS),",",PSGOERS1) Q:'PSGOERS2 S Y=+^TMP("PSJON",$J,PSGOERS2),F=$G(^PS(55,PSGP,5,Y,0)),D=$G(^(.2)) D HMSG I F G EN
  1. I $P(PSJSYSP0,"^",3) D I '$D(PSGFOK) S X="" G DONE
  1. .NEW PSGRENEW S PSGRENEW=1
  1. .S PSGORD=^TMP("PSJON",$J,+PSGODDD(1)),DA=+PSGORD,DA(1)=PSGP,PSGWLL=$S($P(PSJSYSW0,"^",4):+$G(^PS(55,PSGP,5.1)),1:0),PSGOEE="R" W ! D DATE^PSGOER0(PSGP,PSGORD,PSGDT)
  1. .I '$D(PSGFOK(106)) W $C(7),!,"...order",$E("s",$L(PSGODDD(1),",")>2)," NOT renewed..." K PSGFOK Q
  1. .I 'PSGNEDFD,$P(PSJSYSW0,"^",4),PSGFD'<PSGWLL S $P(^PS(55,PSGP,5.1),"^")=+PSGFD
  1. ;W ! F PSGOERS=1:1:PSGODDD F PSGOERS1=1:1 S PSGOERS2=$P(PSGODDD(PSGOERS),",",PSGOERS1) Q:'PSGOERS2 S PSGORD=^TMP("PSJON",$J,PSGOERS2) D RENEW
  1. W !
  1. N EXITLOOP S EXITLOOP=0
  1. F PSGOERS=1:1:PSGODDD D
  1. .F PSGOERS1=1:1 D Q:EXITLOOP=1
  1. ..S PSGOERS2=$P(PSGODDD(PSGOERS),",",PSGOERS1)
  1. ..I 'PSGOERS2 S EXITLOOP=1 Q
  1. ..S PSGORD=^TMP("PSJON",$J,PSGOERS2)
  1. ..I $$CHKCOM Q
  1. ..I '$$LS^PSSLOCK(DFN,PSGORD) W !,$P($$DRUGNAME^PSJLMUTL(DFN,PSGORD),"^",1),!,"NO ACTION WAS TAKEN",!,$C(7) HANG 1 Q
  1. ..D RENEW
  1. ..; Call the unlock procedure
  1. ..D UNL^PSSLOCK(DFN,PSGORD)
  1. ..I $G(PSGOORD) D UNL^PSSLOCK(DFN,PSGOORD)
  1. S X=""
  1. DONE ;
  1. D INIT^PSJLMHED(1)
  1. K DA,DIE,DR,FDSD,PSGAL,PSGALR,PSGFD,PSGFOK,PSGLMT,PSGND4,PSGODDD,PSGOERS,PSGOERS1,PSGOERS2,PSGONW,PSGOPR,PSGORD,PSGOSD,PSGPOSA,PSGPOSD,PSGPR,PSGPX,PSGSD
  1. K PSGST,PSGTOL,PSGTOO,PSGUOW,PSGWLL,PSJSPEED,PSGDT,ND,Q,Q1,PSGDO,PSGOER1,PSGPDRG,PSGPDRGN,PSGOER0,PSGOER2,PSGND4,PSGSI,PSGOSD,PSGOFD,PSGNEDFD,%,Y,F,D
  1. Q
  1. GRI ; get renewal info
  1. HMSG ; hold/'not to be given' message
  1. S X=$P($G(^PS(50.7,+D,0)),"^") S:X]"" X=X_" "_$P(D,"^",2)
  1. I $P(F,"^",22) S H="has been marked as 'NOT TO BE GIVEN'" D WO Q
  1. I $P(F,"^",9)="H" S H="is ON HOLD" D WO Q
  1. I $P(F,"^",27)]"",$P(F,"^",26) S H="has been "_$S($P(F,"^",24)="E":"EDITED",1:"RENEWED") D WO Q
  1. I ($P($G(^PS(50.7,+D,0)),"^",4)]"")&($P($G(^(0)),"^",4)'>DT) S H="is no longer an active Orderable Item" D WO Q
  1. N PSGDFLG,DRG,DRGPT
  1. S PSGDFLG=1 F DRG=0:0 S DRG=$O(^PSDRUG("ASP",+D,DRG)) Q:'DRG I $P(^PSDRUG(DRG,2),U,3)["U",($G(^PSDRUG(DRG,"I"))=""!($G(^("I"))>DT)) S PSGDFLG=0 Q
  1. I PSGDFLG S H="is no longer an active Dispense drug" D WO Q
  1. S F=0,X=$P($G(^PS(55,PSGP,5,Y,2)),"^",2) S:X>PSGOSD PSGOSD=X Q
  1. WO ;
  1. W $C(7)," ??",! W:X]"" !,X S H1="Order number "_$G(PSGOERS2)_" "_H_", and cannot be renewed." W ! F H2=1:1:$L(H1," ") S H3=$P(H1," ",H2) W:$L(H3)+$X>78 ! W H3," "
  1. S F=1 K H,H1,H2,H3 Q
  1. CHKCOM() ; Check if this order is a complex order
  1. S PSJCOM=0
  1. I PSGORD=+PSGORD S PSJCOM=PSGORD W !," Order ",PSGOERS2," is part of a complex order series, and cannot be renewed.",! H 2 Q PSJCOM
  1. S PSJCOM=$S(PSGORD["U":$P($G(^PS(55,PSGP,5,+PSGORD,.2)),U,8),1:$P($G(^PS(53.1,+PSGORD,.2)),U,8))
  1. I PSJCOM W !," Order ",PSGOERS2," is part of a complex order series, and cannot be renewed.",! H 2
  1. Q PSJCOM