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

PSIVOPT2.m

Go to the documentation of this file.
  1. PSIVOPT2 ;BIR/PR,MLM-OPTION DRIVER (CONT) ;02 Mar 99 / 9:27 AM
  1. ;;5.0;INPATIENT MEDICATIONS ;**23,29,58,110,127,133,135,157,181,258,287,374**;16 DEC 97;Build 2
  1. ;
  1. ; Reference to ^PS(55 is supported by DBIA# 2191.
  1. ; Reference to ^PSSLOCK is supported by DBIA #2789
  1. ;
  1. D ; Discontinue order.
  1. D NATURE^PSIVOREN I '$D(P("NAT")) W !,$C(7),"Order Unchanged." S COMQUIT=1 Q
  1. ;* 8/2* D EN1^PSJHL2(DFN,"OD",+ON55_"V","ORDER DISCONTINUED"),D1
  1. I '$$REQPROV^PSGOEC W !,$C(7),"Order Unchanged." S (COMQUIT,PROVQUIT)=1 Q
  1. I 'PSJCOM D
  1. .D D1
  1. .S PSIVALT=1,PSIVALCK="STOP",PSIVREA="D",ON=ON55 D LOG^PSIVORAL S P(3)=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3)
  1. I PSJCOM N COMFLG S COMFLG=0 D
  1. .I ON55'["P" N COMFLG,O,OO S (COMFLG,O)=0,OO="" F S O=$O(^PS(55,"ACX",PSJCOM,O)) Q:'O F S OO=$O(^PS(55,"ACX",PSJCOM,O,OO)) Q:OO="" Q:COMFLG D
  1. .. Q:OO=ON55 I '$$LS^PSSLOCK(DFN,OO) S COMFLG=1 Q
  1. I PSJCOM Q:COMFLG N O,OO S O=0,OO="" F S O=$O(^PS(55,"ACX",PSJCOM,O)) Q:'O F S OO=$O(^PS(55,"ACX",PSJCOM,O,OO)) Q:OO="" D
  1. .I OO["V" S ON55=OO D D1 S PSIVALT=1,PSIVALCK="STOP",PSIVREA="D",ON=ON55 D LOG^PSIVORAL N PSJORD S P(3)=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3),PSJORD=ON55 D HL^PSIVORA Q
  1. .I OO["U" N PSGORD,PSJORD,PSJNOO K DA D NOW^%DTC S PSGDT=%,T=$E("T",'PSJSYSU),PSGALR=20,PSGP=DFN,DA=+OO,DA(1)=PSGP,(PSGORD,PSJORD)=OO,PSJNOO=P("NAT") D
  1. ..S CF=$S($P(PSJSYSP0,U,5):1,PSGORD["U":0,1:($P($G(^PS(53.1,+PSGORD,0)),U,25)=""&($P($G(^(4)),U,7)=DUZ))) D ASET^PSGOEC,AC^PSGOEC
  1. Q
  1. D1 N %,DA,DIE,DIU,STP,NSTOP
  1. S NSTOP=$$DATE^PSJUTL2(),STP=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3),NSTOP=+$S(STP>NSTOP:NSTOP,1:STP),P(17)="D"
  1. K TMP
  1. S TMP(55.01,""_+ON55_","_DFN_","_"",109)=NSTOP
  1. S:'$P($G(^PS(55,DFN,"IV",+ON55,2)),U,7) TMP(55.01,""_+ON55_","_DFN_","_"",116)=STP
  1. S TMP(55.01,""_+ON55_","_DFN_","_"",100)="D"
  1. S TMP(55.01,""_+ON55_","_DFN_","_"",157)=""
  1. S TMP(55.01,""_+ON55_","_DFN_","_"",.03)=NSTOP
  1. S PSIVACT=1
  1. D FILE^DIE("","TMP")
  1. K TMP
  1. I $S($G(PSIVAC)="OD":0,$G(PSIVAC)'="AD":1,$G(PSGALO)<1060:0,1:$P($G(PSJSYSW0),U,15)) S X=$S($G(PSIVAC)="AD":1,1:2) D ENLBL^PSIVOPT(X,$S(X=1:+$G(PSGUOW),1:DUZ),DFN,3,+ON55,$E("AD",1,3-X))
  1. D:'$D(PSJIVORF) ORPARM^PSIVOREN Q:'PSJIVORF ;* S ORIFN=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,21) Q:'ORIFN
  1. Q
  1. ;
  1. R ; Renew order.
  1. ;I PSJCOM D RIV^PSJCOMR Q
  1. I PSJCOM D ^PSJCOMR Q
  1. I P(17)="D",P(12) N ERR D RI W:$G(ERR)=1 $C(7)," Order unchanged." I $G(ERR)<2 S COMQUIT=1 Q
  1. I $G(PSGORQF) S COMQUIT=1 Q
  1. ;PSJOCFLG is killed of after the OC is performed. The Dosing is still need to trigger(again) if the
  1. ; user said "no" at OK prompt and a new stop date is entered.
  1. NEW PSJOCFLG S PSJOCFLG=1
  1. ;
  1. R1 ;
  1. I $$EXPIRED^PSGOER(DFN,ON55) D Q
  1. .W !?3," THIS ORDER HAS BEEN INACTIVE FOR ONE OR MORE SCHEDULED ADMINISTRATIONS"
  1. .W !?20," AND CANNOT BE RENEWED!"
  1. ;*287 - Prevent renewal if schedule invalid
  1. I $G(P(9))]"",'$$DOW^PSIVUTL(P(9)),'$$PRNOK^PSGS0(P(9)) I '$D(^PS(51.1,"AC","PSJ",P(9))) D Q
  1. . W !!?3,"This order contains an invalid schedule and CANNOT be renewed!" D PAUSE^VALM1
  1. I '$G(PSGDT) D NOW^%DTC S PSGDT=+$E(%,1,12) ;*258 - Set PSGDT
  1. N PSJRNWDT,PSJOSTOP,OREASON S PSJRNWDT=$$DATE2^PSJUTL2(PSGDT) S:$G(ON55) PSJOSTOP=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3) I '(PSJOSTOP>P(2)),$G(PSGDT) S PSJOSTOP=PSGDT
  1. S (PSIVOK,EDIT)="25^1" S P2=P(2),P(2)=PSJRNWDT D EDIT^PSIVEDT S P(2)=P2 K P2 I X="^" Q
  1. NEW PSGORQF K PSGORQF S PSIVRNFG=1 D:$G(PSJOCFLG) OC^PSIVOC K PSJOCFLG D:'$G(PSGORQF) IN^PSJOCDS($G(ON55),"IV","") K PSIVRNFG W ! Q:$G(PSGORQF)
  1. S P(11)=$$ENRNAT^PSGOU($P($G(^PS(55,DFN,"IV",+ON55,2)),U,10),+VAIN(4),P(9),P(11))
  1. D OK G:X["N" R1 I X=U D RD Q
  1. S PSIVCHG=2
  1. S P(17)="A",OREASON=P("RES"),P("RES")="R",P("FRES")="" D:'$D(PSJIVORF) ORPARM^PSIVOREN I PSJIVORF D Q:'$D(P("NAT"))
  1. .D NATURE^PSIVOREN I '$D(P("NAT")) D RD Q
  1. .S ON=ON55
  1. S P(16)="",PSJORIFN="",PSIVACT=1,P("21FLG")="",P("RES")=OREASON D SET55^PSIVORFB
  1. D:$P(^PS(55,DFN,"IV",+ON55,0),U,17)="A" RUPDATE^PSIVOREN(DFN,ON55,P(2))
  1. I PSJIVORF,$P(^PS(55,DFN,"IV",+ON55,0),U,17)'="A" S X=$$LS^PSSLOCK(DFN,+ON55_"V") D
  1. .D EXPOE^PSGOER(DFN,ON55)
  1. .S P("RES")="R",PSJREN=1
  1. .D ENUDTX^PSJOREN(DFN,ON55,"NR"),EN1^PSJHL2(DFN,"SN",+ON55_"V","ORDER RENEWED"),UPDREN(DFN,ON55,PSJRNWDT,P(6),PSJOSTOP,P("NAT"))
  1. S OD=P(2)
  1. D VF1^PSJLIACT("","",1),UNL^PSSLOCK(DFN,+ON55_"V")
  1. D ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,"R")
  1. I $G(PSJOSTOP),$G(ON55),$G(DFN) D STIX^PSIVOREN(PSJOSTOP,ON55,DFN)
  1. Q
  1. ;
  1. RD ; Delete for renew.
  1. ;Q:'$G(PSJVFY)
  1. ;D DEL55^PSIVORE2 S (ON55,P("OLDON"))=P("PON") D GT55^PSIVORFB
  1. Q
  1. ;
  1. OK ;Print example label, run order through checker, ask if it is ok.
  1. S P16=0,PSIVEXAM=1,(PSIVNOL,PSIVCT)=1 D GTOT^PSIVUTL(P(4)) I ($G(P("PD"))="") D GTPD^PSIVORE2
  1. D ^PSIVCHK I $D(DUOUT) S X="^",COMQUIT=1 Q
  1. I ERR=1 S X="N",COMQUIT=1 Q
  1. W ! D ^PSIVORLB K PSIVEXAM S Y=P(2) W !,"Start date: " X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2),?30," Stop date: " S Y=P(3) X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2),!
  1. ;PSJ*5*157 EFD FOR IV
  1. D EFDIV^PSJUTL($G(ZZND))
  1. I $G(PSIVCHG),($G(PSIVREA)'="R") W !,"*** This change will cause a new order to be created. ***"
  1. S X="Is this O.K.: ^"_$S(ERR:"N",1:"Y")_"^^NO"_$S(ERR'=1:",YES",1:"") D ENQ^PSIV I X["?" S HELP="OK" D ^PSIVHLP G OK
  1. Q
  1. ;
  1. RI ; Reinstate Auto-DC'ed order.
  1. N DA,DIE,DIR,DIU,DR,PSIVACT,PSIVALT,PSIVALCK,PSIVREA W !!,$C(7),"This order has been Auto-DC'ed."
  1. S DIR(0)="Y",DIR("A")="Reinstate this order" D ^DIR K DIR I 'Y S ERR=1 Q
  1. D NOW^%DTC I %>$P($G(^PS(55,DFN,"IV",+ON55,2)),U,7) D
  1. .K DIR S ERR=1,DIR(0)="Y",DIR("A",1)="The original stop date of this order has past.",DIR("A")="Do you wish to renew this order" D ^DIR K DIR S ERR=$S(Y:2,1:1)
  1. Q:$G(ERR) S X=$G(^VA(200,+P(6),"PS")) I $S('X:1,'$P(X,U,4):0,DT<$P(X,U,4):0,1:1) S ERR=1
  1. I $G(ERR) W !!,$C(7),"This order's provider is no longer valid. Please enter a valid provider." S (EDIT,PSIVOK)=1 D EDIT^PSIVEDT I $G(DONE) W $C(7),"Order unchanged." S ERR=1 Q
  1. N PSGALO S PSGALO=18530 D ENARI^PSIVOPT(DFN,ON,DUZ,PSGALO)
  1. Q
  1. ;
  1. UPDREN(DFN,ORD,RNWDT,PROV,OSTOPDT,PSJNOO) ;
  1. Q:'DFN!'ORD!'RNWDT!'PROV!'OSTOPDT!(PSJNOO="")
  1. ;*PSJ*5*258
  1. N DR,DA,DIC,DIE,DD,DO,ND0,PSGOEORD,DINUM
  1. S DIC="^PS(55,"_DFN_",""IV"","_+ORD S ND0=$G(@(DIC_",0)")),PSGOEORD=$P(ND0,"^",21) I $G(ON)["P",$G(PSGOLDOE) S PSGOEORD=PSGOLDOE
  1. S DIC=DIC_",14,",DIC(0)="L",DIC("P")="55.1138DA",ND14=$G(@(DIC_"0)")),DINUM=$P(ND14,"^",3)+1,DA(2)=DFN,DA(1)=+ORD D
  1. .S DIC("DR")=".01////"_$G(RNWDT)_";1////"_$G(DUZ)_";2////"_$G(PROV)_";3////"_$G(OSTOPDT)_";4////"_+PSGOEORD,X=$G(RNWDT) D FILE^DICN
  1. Q