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

PSGOERI.m

Go to the documentation of this file.
  1. PSGOERI ;BIR/CML3 - REINSTATE A DC'D ORDER ;06 Aug 98 / 2:17 PM
  1. ;;5.0;INPATIENT MEDICATIONS ;**17,27,31,88,110,137,181,320**;16 DEC 97;Build 7
  1. ;
  1. ; Reference to ^PS(55 is supported by DBIA# 2191
  1. ;
  1. ENRI ;
  1. S PSGALR=80,PSGFD=$P($G(^PS(55,PSGP,5,+PSGORD,2)),"^",3) I 'PSGFD W:'$D(PSJUNDC) $C(7),$C(7),!?3,"I CANNOT REINSTATE THIS ORDER! THE OLD STOP DATE IS MISSING!" Q
  1. I PSGFD'>PSGDT Q:$D(PSJUNDC) W !!,"This order has technically expired as of ",$$ENDTC^PSGMI,"." F S %=1 W !!,"Do you want to RENEW this order" D YN^DICN Q:% D
  1. .W !!?2,"This order has expired, and cannot be renewed. But the order can be",!,"reinstated. Answer 'YES' to reinstate the order now. Answer 'NO' (or '^') if",!,"you do not want to reinstate this order now."
  1. I PSGFD'>PSGDT G:%'=1 DONE S PSGRRF=0 D NEW^PSGOER,DONE^PSGOER G DONE
  1. W:'$D(PSJUNDC) !!,"...reinstating this order..."
  1. ;Create a list of recipients beyond normal mail group
  1. D:$D(PSJUNDC) ; do only if from movement deletion
  1. .I $P(^PS(55,PSGP,5,+PSGORD,4),U,1)'="" S PSJSENTO($J,$P(^PS(55,PSGP,5,+PSGORD,4),U,1))="" ; Record verifying Nurse
  1. .I $P(^PS(55,PSGP,5,+PSGORD,4),U,3)'="" S PSJSENTO($J,$P(^PS(55,PSGP,5,+PSGORD,4),U,3))="" ; Record verifying Pharmacist
  1. .I $P(^PS(55,PSGP,5,+PSGORD,4),U,5)'="" S PSJSENTO($J,$P(^PS(55,PSGP,5,+PSGORD,4),U,5))="" ; Record Physician
  1. .I $P(^PS(55,PSGP,5,+PSGORD,0),U,2)'="" S PSJSENTO($J,$P(^PS(55,PSGP,5,+PSGORD,0),U,2))="" ; Record Provider
  1. ;If a duplicate order exists do not reinstate the older one. Record in ^TMP for later advice in auto e-mail (PSJADT2)
  1. D NOW^%DTC
  1. I $D(PSJUNDC) I $$CHECKDUP^PSGOERI(PSGP,+PSGORD) S ^TMP("PSJNOTUNDC",$J,PSGP,PSGORD_"U")="" G DONE
  1. ;S DR=$S(+$P($G(^PS(55,PSGP,5,+PSGORD,4)),U,18)=1:"28///H",+$P($G(^(4)),U,26)=1:"28///H",1:"28////A")_";34////"_PSGFD_";136////@"
  1. S DR=$S(+$P($G(^PS(55,PSGP,5,+PSGORD,4)),U,26)=1:"28///H;136////HP",+$P($G(^(4)),U,18)=1:"28///H;136////@",1:"28////A;136////@")_";34////"_PSGFD
  1. S Z=$G(^PS(55,PSGP,5,+PSGORD,4)),$P(Z,U,11)="",$P(Z,"^",15,17)="^^" S:'$D(PSJUNDC) $P(Z,"^",PSJSYSU,PSJSYSU+1)=DUZ_"^"_PSGDT S ^(4)=Z W "."
  1. N CHKIT S CHKIT=$G(^PS(55,PSGP,5,+PSGORD,0)) I $P(CHKIT,U,26)["P",($P(CHKIT,U,27)="R") S DR=DR_";105///@;107///@"
  1. S DIE="^PS(55,"_PSGP_",5,",DA(1)=PSGP,DA=+PSGORD,PSGAL("C")=$S($D(PSJUNDC):40,1:(PSJSYSU*10))+18500 D ^PSGAL5 W "." D ^DIE W "."
  1. S X=$P(^PS(55,PSGP,5,+PSGORD,0),"^",20),$P(^(0),"^",20)="" K:X ^PS(55,"AUDDD",X,PSGP,+PSGORD) ;Removed cross reference after reinstate order.
  1. ;S X=$O(^ORD(101,"B","PS EVSEND OR",0))_";ORD(101,",PSOC="SC",PSJORDER=$$ORDER^PSJHLU(PSGORD) D EN1^XQOR:X K X
  1. S ^TMP("PSJUNDC",$J,PSGP,PSGORD_"U")=""
  1. D EN1^PSJHL2(PSGP,"SC",+PSGORD_"U",$S($D(PSJUNDC):"AUTO REINSTATED",1:"REINSTATED"))
  1. Q:$S('$D(PSJUNDC):0,PSGALO=18540:1,1:'$P($G(PSJSYSW0),U,15))
  1. S PSGTOL=$S($D(PSJUNDC):3,1:2),PSGUOW=$S($D(PSJUNDC):PSJUOW,1:DUZ)
  1. I $D(^PS(53.41,1,1,+PSGUOW,1,PSGP,1,1,1,+PSGORD)) K DIK,DA S DIK="^PS(53.41,"_1_",1,"_+PSGUOW_",1,"_PSGP_",1,1,1,",DA=+PSGORD,DA(1)=1,DA(2)=PSGP,DA(3)=+PSGUOW,DA(4)=1 D ^DIK
  1. E D
  1. .S X=0 S:$D(PSJUNDC) X=$O(^PS(59.6,"B",+PSGUOW,0)),X=$P($G(^PS(59.6,+X,0)),U,15)
  1. .I $S(X:1,'PSJSYSL:0,PSJSYSL<3:1,1:$P(^PS(55,PSGP,5,DA,4),"^",+PSJSYSU'=3+9)) D
  1. ..K DA S DA=+PSGORD,DA(1)=PSGP,$P(^PS(55,PSGP,5,DA,7),"^",1,2)=PSGDT_"^RE",PSGTOO=1,PSGUOW=$S($D(PSJUNDC):+PSJUOW,1:DUZ) D ENL^PSGVDS W "."
  1. W:'$D(PSJUNDC) ".DONE!" Q
  1. ;
  1. DONE ;
  1. K DA,DIE,DR,PSGAL,PSGALR,PSGFD,PSGID,PSGOD,RF,Z
  1. Q
  1. CHECKDUP(PSGP,PSGORD) ;
  1. N Z,ZZ,PSJCOM
  1. S FOUND=0
  1. S PSGX=+$G(^PS(55,PSGP,5,+PSGORD,.2)),PSJCOM=+$P($G(^(.2)),"^",8)
  1. I PSGX'="" D
  1. .F Z=%:0 S Z=$O(^PS(55,+PSGP,5,"AUS",Z)) Q:'Z!FOUND D
  1. ..F ZZ=0:0 S ZZ=$O(^PS(55,+PSGP,5,"AUS",Z,ZZ)) Q:'ZZ!FOUND D
  1. ...I PSJCOM>0 Q:+$P($G(^PS(55,+PSGP,5,ZZ,.2)),"^",8)=PSJCOM
  1. ...I +$G(^PS(55,+PSGP,5,ZZ,.2))=PSGX D
  1. ....S FOUND=1
  1. Q FOUND