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

PSJCLOR4.m

Go to the documentation of this file. 
  1. PSJCLOR4 ;BIR/JCH - INPATIENT MEDICATIONS PROFILE FOR CLINIC ORDERS ;25 SEP 97 / 7:43 AM
  1.  ;;5.0;INPATIENT MEDICATIONS;**275**;16 DEC 97;Build 157
  1.  ;
  1.  ; Reference to ^PS(55 is supported by DBIA# 2191
  1.  ;
  1.  N PFLG,PSJNEW,PSGPTMP,PPAGE,QFLG S PSJNEW=1
  1.  N PSGLI,PSGWD,PSJAT,PSJPNRB,PSJPWDO,PSJSTOP,PSJTEAM
  1.  ;
  1. EN ;
  1.  G:$D(XQUIT) DONE
  1.  D @$S('$D(PSJEXTP):"^PSIVXU",1:"ENCV^PSGSETU")
  1.  G:$D(XQUIT) DONE S PSGPTMP=0,PPAGE=1 K PSJSEL D @$S($D(PSJEXTP):"P^PSJPDIR",1:"GWP^PSJPDIR") G:$G(PSJSTOP)=1 DONE S:$D(PSJEXTP) PSJSEL("SELECT")="P"
  1.  I $G(PSJSEL("WG"))="^OTHER",PSJSEL("SELECT")="G",PSJSTOP=2 S PSJSEL("SELECT")="C",PSJSEL("RBP")="P"
  1.  D ENL^PSJO3 G:"^N"[PSJOL EN D GO
  1.  ;
  1. DONE ;
  1.  K ^TMP("PSJON",$J),^TMP("PSJ",$J)
  1.  D ENIVKV^PSGSETU K AND,AT,C,CA,DDH,DFN,DN,DOB,DRGI,DRGN,DRGT,FIL,FQC,HDR,I1,J,JJ,MF,NF,O,OD,ON,ON55,P,P1,PDRG,PG,PPN,PRI,PRIV,PSGLMT,PSGOE,PSGONC,PSGONR,PSGONV,PSGORD,PSGSS,PSGSSH,PSGON,PSGPR,PSGPRP
  1.  K PSIVAC,PSIVCT,PSIVREA,PSIVSCR,PSIVUP,PSIVX,CLINIC,JDFN,POP,PSGTIR,PSJEXTP,PSJNKF,DTOUT,DUOUT,Q,STDTE,X,Y,ZTDESC
  1.  K PSJACNWP,PSJACOK,PSJDEV,PSJDBL,PSJION,PSJON,PSJOS,PSJP,PSJSEL,PSJSS,PSJSSH,PSJPRW,PSJPRWN,PSJPRWG,PSJPRWGN
  1.  K PSJOPC,PSJORD,PSJQ,PSJIVOF,PSJOCNT,PSJPR,PSJPRA,PSJPRF,PSJPRP,PSJON,PSJS1,PSJS2,PSJS3,PSJS4,PSJPR,PX,HDT,PSGODT,RF,SD,SLS,SSN,TF,UD,WD,WDP,WT,PSJORIFN,RB,RCT,SUB,XQUIT,ZTOUT
  1.  Q
  1.  ;
  1. GO ;
  1.  S PSJPRP="P",PSJPRA="" G:PSJSEL("SELECT")'="P" DEV
  1.  N DIR S DIR(0)="SAO^P:PROFILE;E:EXPANDED VIEWS;B:BOTH",DIR("A")="Show PROFILE only, EXPANDED VIEWS only, or BOTH: ",DIR("B")="PROFILE",DIR("?")="^D PH^PSJPR" W ! D ^DIR G:"^"[Y EN S PSJPRP=Y
  1.  I "EB"[PSJPRP F  R !!,"Show SHORT, LONG, or NO activity log?  NO// ",AT:DTIME D ALC^PSGVW0 I Q S PSJPRA=AT Q
  1.  G:PSJPRA="^" EN
  1. DEV ;
  1.  S PSJOS=$P(PSJSYSP0,"^",11)
  1.  K ZTSAVE S PSGTIR="ENQ^PSJCLOR4",ZTDESC="INPATIENT PATIENT PROFILE" F X="DFN","PSJSEL(","PSJOL","PSJOS","PSJPRA","PSJPRP","PSGPTMP","PPAGE","PSJEXTP","PSJHDATE" S ZTSAVE(X)=""
  1.  D ENQ
  1.  K DIR S DIR(0)="YO",DIR("A")="Print this profile to a printer",DIR("B")="N" D ^DIR I $G(Y) D ENDEV^PSGTI Q:POP  D:'$D(IO("Q")) ENQ
  1.  Q
  1.  ;
  1. ENQ ;
  1.  S Y="PSJPR" F X="W","WG" S:$D(PSJSEL(X)) @(Y_X)=+PSJSEL(X),@(Y_X_"N")=$P(PSJSEL(X),U,2)
  1.  S PSJACNWP=1 K ^TMP("PSJAT",$J) S PSJPR=IO'=IO(0)!($E(IOST)'="C"),PSGPRP=PSJPRP
  1.  I PSJSEL("SELECT")="P" S PPN="" F  S PPN=$O(PSJSEL("P",PPN)) Q:PPN=""  D  Q:$G(X)?1"^"."^"
  1.  .F DFN=0:0 S (PSGP,DFN)=$O(PSJSEL("P",PPN,DFN)) Q:'DFN  D ENBOTH^PSJAC,PP Q:$G(X)?1"^"."^"
  1.  D:PSJSEL("SELECT")'="P" @("P"_PSJSEL("SELECT")) I PSJPR W:$Y @IOF D ^%ZISC,DONE
  1.  Q
  1. PC ;
  1.  K ^TMP("PSJPR",$J,"OUTPAT")
  1.  S (STDTE,CLINIC,JDFN)=0
  1.  F  S STDTE=$O(^PS(55,"AIVC",STDTE)) Q:STDTE=""  F  S CLINIC=$O(^PS(55,"AIVC",STDTE,CLINIC)) Q:CLINIC=""  D
  1.  . F  S JDFN=$O(^PS(55,"AIVC",STDTE,CLINIC,JDFN)) Q:JDFN=""  I '$D(^TMP("PSJPR",$J,"OUTPAT",JDFN)) S DFN=JDFN K ^TMP("PSJAT",$J) D PAT,PAT1,PJ
  1.  S (STDTE,CLINIC,JDFN)=0
  1.  F  S STDTE=$O(^PS(55,"AUDC",STDTE)) Q:STDTE=""  F  S CLINIC=$O(^PS(55,"AIVC",STDTE,CLINIC)) Q:CLINIC=""  D
  1.  . F  S JDFN=$O(^PS(55,"AUDC",STDTE,CLINIC,JDFN)) Q:JDFN=""  I '$D(^TMP("PSJPR",$J,"OUTPAT",JDFN)) S DFN=JDFN K ^TMP("PSJAT",$J) D PAT,PAT1,PJ
  1.  Q
  1. PJ ;
  1.  S ^TMP("PSJPR",$J,"OUTPAT",JDFN)=""
  1. PG ;
  1.  F PSJPRW=0:0 S PSJPRW=$O(^PS(57.5,"AC",PSJPRWG,PSJPRW)) Q:'PSJPRW  S PSJPRWN=$P($G(^DIC(42,+PSJPRW,0)),"^") I PSJPRWN]"" D PW Q:$G(X)="^"
  1.  Q
  1. PW ;
  1.  K ^TMP("PSJAT",$J) F DFN=0:0 S (DFN,PSGP)=$O(^DPT("CN",PSJPRWN,DFN)) Q:'DFN  D PAT
  1.  D PAT1
  1.  Q
  1. PAT ;
  1.  S RB=$P($G(^DPT(DFN,.101)),U),PPN=$P($G(^(0)),U),X=$S(PSJSEL("RBP")="R":RB,1:PPN),AT=""
  1.  I $D(PSJSEL("TM")) S:RB]"" AT=$O(^PS(57.7,"AWRT",PSJPRW,RB,0)) Q:$S($D(PSJSEL("TM","ALL")):0,AT="":1,1:'$D(PSJSEL("TM",AT)))
  1.  F Y="AT","RB","X" S:@Y="" @Y="ZZ"
  1.  S ^TMP("PSJAT",$J,AT,X,DFN)=""
  1.  Q
  1. PAT1 ;
  1.  K PSJDBL S PSJAT="" F  S PSJAT=$O(^TMP("PSJAT",$J,PSJAT)) Q:PSJAT=""!$G(PSJDBL)  D
  1.  .S PSJPNRB="" F  S PSJPNRB=$O(^TMP("PSJAT",$J,PSJAT,PSJPNRB)) Q:PSJPNRB=""  S (DFN,PSGP)=+$O(^TMP("PSJAT",$J,PSJAT,PSJPNRB,0)) D ENBOTH^PSJAC,PP I $G(X)["^" S:X="^^" PSJDBL=1 Q
  1.  Q
  1. PP ;
  1.  I PSJPRP'="E" D ^PSJO I PSJPRP="P",'PSJPR D:'PSJON READ^PSJUTL Q:$G(X)?1"^"."^"  I PSJON S PSJPRF=1 D ENVW^PSJOE0 K PSGPRF Q
  1.  Q:PSJPRP="P"  I PSJPRP="E" U IO S PSJON=0,PSJDEV=PSJPR D @$S($D(PSJEXTP):"EN^PSJH1,ENGET^PSJO3",1:"EN^PSJO1(3),ENGET^PSJO3")
  1.  I 'PSJPR,PSJSEL("SELECT")'="P",'$D(^TMP("PSG",$J)) D READ^PSJUTL Q
  1.  I PSJPRP'="E",'PSJPR D PP3 Q:$D(DUOUT)!$D(DTOUT)
  1.  S (PSJS1,PSJS2,PSJS3,PSJS4,X)=""
  1.  F PSJQ=0:0 S PSJS1=$O(^TMP("PSJ",$J,PSJS1)) Q:PSJS1=""  F PSJQ=0:0 S PSJS2=$O(^TMP("PSJ",$J,PSJS1,PSJS2)) Q:PSJS2=""  F PSJQ=0:0 S PSJS3=$O(^TMP("PSJ",$J,PSJS1,PSJS2,PSJS3)) Q:PSJS3=""  D PP1
  1.  D:X'["^"&PSJPR BOT^PSJO3 K ^TMP("PSJ",$J) Q
  1. PP1 ;
  1.  F PSJQ=0:0 S PSJS4=$O(^TMP("PSJ",$J,PSJS1,PSJS2,PSJS3,PSJS4)) Q:PSJS4=""  D PP2
  1.  Q
  1.  ;
  1. PP2 ; Display selected order.
  1.  N PSJPRF,PSJLM S PSJORD=PSJS4 I $S(PSJORD["V":1,PSJORD["P":$P($G(^PS(53.1,+PSJORD,0)),U,4)="F",1:0) D  Q
  1.  .S PSJPRF=1 D ENINP^PSIVOPT(PSGP,PSJORD),PP3 Q:$D(DUOUT)!$D(DTOUT)  I PSJPRA'="N" I PSJORD'["P" D ENLOG^PSIVVW1,PP3 Q
  1.  S PSGORD=PSJORD D EN2^PSGVW,PP3 Q:$D(DUOUT)!$D(DTOUT)  I PSJPRA'="N",((PSJS1["A")!(PSJS1["O")) S AT=PSJPRA D ENA^PSGVW0 D PP3
  1.  Q
  1. PP3 S X="" I 'PSJPR K DIR S DIR(0)="E" D ^DIR S:$D(DUOUT)!$D(DTOUT) X="^" I X["^" S (PSJS1,PSJS2,PSJS3,PSJS4)="~"
  1.  Q
  1.  ;
  1. PH ;
  1.  W !!?2,"Enter a 'P' to print ONLY the PROFILE of orders for this patient.  Enter an",!,"'E' to print ONLY the EXPANDED VIEW of the orders for this patient.  Enter a",!,"'B' to have BOTH the profile (first) and the expanded views print."
  1.  W "  Enter an '^'to exit." Q
  1.  ;
  1. ENOR(PSGP) ;S (PSGP,DFN)=+ORVP,PSGP(0)=^DPT(PSGP,0)
  1.  S DFN=+PSGP,PSGP(0)=^DPT(PSGP,0)
  1. ENLM N PSJNEW,PSGPTMP,PPAGE S PSJNEW=1
  1.  S PSGPTMP=0,PPAGE=1
  1.  D ENCV^PSGSETU
  1.  D ENBOTH^PSJAC D:$D(PSJEXTP) CNV^PSJP D ENL^PSJO3 I "^N"'[PSJOL S PSJSEL("SELECT")="P",PSJSEL("P",PSGP(0),PSGP)="",(PSJPRW,PSJPRWG)=0,(PSJPRWN,PSJPRWGN)="",XQUIT="YES" D GO
  1.  ;* S PSJNKF=1 D READ^PSJUTL G DONE
  1.  S PSJNKF=1 G DONE
  1.  Q
  1.  ;
  1. A34 ; Stop date Active Unit Dose
  1.  S MSG=0,PSGF2=34
  1.  K PSGFDX
  1.  I $G(PSJORD),$G(PSGP) I $$COMPLEX^PSJOE(PSGP,PSJORD) S PSGOEE=0 D  Q
  1.  . W !!?5,"Stop Date/Time may not be edited for active complex orders." D PAUSE^VALM1
  1.  . D A34DONE
  1.  W !,"STOP DATE/TIME: "_$S($P(PSGFDN,"^")]"":$P(PSGFDN,"^")_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 D A34DONE Q
  1.  I X="",PSGFD W "   "_$P(PSGFDN,"^") G W34
  1.  I $E(X)="^" D ENFF^PSGOE92 G:Y>0 @Y G A34
  1.  I X="@"!(X?1."?") W:X="@" $C(7),"  (Required)" S:X="@" X="?" D ENHLP^PSGOEM(55.06,34)
  1.  I X=+X,(X>0),(X'>2000000) G A34:'$$ENDL^PSGDL(PSGSCH,X) K PSGDLS S PSGDL=X W " ...dose limit..." D ENE^PSGDL
  1.  K %DT S %DT="ERTX",%DT(0)=PSGSD D ^%DT K %DT G:Y'>0 A34 S (PSGFDX,PSGFD)=+Y,PSGFDN=$$ENDD^PSGMI(PSGFD)_"^"_$$ENDTC^PSGMI(PSGFD)
  1. W34 ;Compare to Start Date
  1.  N Z,MSG
  1.  D DOSE^PSGOE91 I $G(Z)]"",Z>$S($G(PSGFD):PSGFD,1:$G(PSGNEFD)) D  G A34
  1.  . S MSG(1)="There is no administration time that falls between the Start Date/Time"
  1.  . S MSG(2)="and the Stop Date/Time."
  1.  . D EN^DDIOL(.MSG)
  1.  I PSGFD<PSGDT W $C(7),!!?13,"*** WARNING! THE STOP DATE ENTERED IS IN THE PAST! ***",! S MSG=1
  1.  Q
  1. A34DONE ; clean up Active UD Stop Date vars
  1.  K MSG
  1.  Q
  1. A25NV ; Stop Date Non-Verified
  1.  K PSGFDX
  1.  W !,"STOP DATE/TIME: "_$S($P(PSGFDN,"^")]"":$P(PSGFDN,"^")_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 G A25DONE
  1.  I X="",PSGFD S X=$P(PSGFDN,"^") ;W "   "_$P(PSGFDN,"^")
  1.  I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A25NV
  1.  I X="@"!(X?1."?") W:X="@" $C(7),"  (Required)" S:X="@" X="?" D ENHLP^PSGOEM(53.1,25)
  1.  I X=+X,(X>0),(X'>2000000) G A25NV:'$$ENDL^PSGDL(PSGSCH,X) K PSGDLS S PSGDL=X W " ...dose limit..." D ENE^PSGDL
  1.  K %DT S %DT="ERTX",%DT(0)=PSGSD D ^%DT K %DT G:Y'>0 A25NV S (PSGFDX,PSGFD,PSGNEFD)=+Y,PSGFDN=$$ENDD^PSGMI(PSGFD)_"^"_$$ENDTC^PSGMI(PSGFD)
  1. W25 ; Loop Stop Date NV
  1.  N Z,MSG
  1.  D DOSE^PSGOE81 I $G(Z)]"",Z>PSGNEFD D  G A25NV
  1.  . S MSG(1)="There is no administration time that falls between the Start Date/Time"
  1.  . S MSG(2)="and the Stop Date/Time."
  1.  . D EN^DDIOL(.MSG)
  1.  I PSGFD<PSGDT W $C(7),!!?13,"*** WARNING! THE STOP DATE ENTERED IS IN THE PAST! ***",! G A25NV
  1.  Q
  1. A25DONE ; NV Stop Date Done
  1.  D EFDNV^PSJUTL
  1.  K MSG
  1.  Q
  1. A25V(DFN,ON) ; Stop Date Active IV
  1.  N X,TMPY,DIR
  1. A25V2 ; IV Stop Date Continued
  1.  I P("IVRM")]"",$S(P(3)<P(2):1,$G(PSIVAC)["E":0,1:1) S PSIVSITE=$G(^PS(59.5,+P("IVRM"),1)),$P(PSIVSITE,"^",20,21)=$G(^PS(59.5,+P("IVRM"),5)) D ENSTOP^PSIVCAL
  1.  I $G(ON)["V"!($G(ON)["U") I $$COMPLEX^PSJOE(DFN,ON) D  Q
  1.  .Q:$G(PSJBKDR)  W !!?5,"This is a Complex Order. Stop Date may not be edited at this point." D PAUSE^VALM1
  1.  S Y=P(3) X ^DD("DD") W !,"STOP DATE/TIME: "_$S(Y]"":Y_"// ",1:"") R X:DTIME S:'$T X=U S:X=U DONE=1 Q:X=""&P(2)  I $E(X)=U!(X=""&P(2)) Q
  1.  I X="@"!(X["?") W $C(7),"  (Required)" S F1=53.1,F2=25,X="?" D ENHLP^PSIVORC1 G A25V2
  1.  K %DT S:X="" X=$G(Y) S:X="" X=P(3) S %DT="TE" D:X'=+X ^%DT
  1.  I X=+X,X>0,X'>2000000 G A25V2:'$$ENDL^PSGDL(P(9),X) D ENDL^PSIVSP
  1.  S TMPY=Y I TMPY["^" S PSJQMSG=0 Q
  1.  I $E(TMPY)="?" K DIR,X,Y D ENHLP^PSGOEM(55.06,10) S PSJQMSG=1 G A25V2
  1.  I TMPY'["." W $C(7),!?5," Time is REQUIRED. Re-enter Start Date. " S PSJQMSG=1 G A25V2
  1.  D DOSE^PSIVEDT1
  1.  I $G(X)="" S X=Y
  1.  I $G(X)="" S X=P(3)
  1.  I $G(Z)]"",Z>X D  G A25V2
  1.  . W !,"There is no administration time that falls between the Start Date/Time"
  1.  . W !,"and Stop Date/Time.",!
  1.  S X=Y S:Y<1!Y'["." X="" G:Y'>0 A25V2 S P(3)=+Y,PSGFDX=1
  1.  Q