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

PSIVACT.m

Go to the documentation of this file.
  1. PSIVACT ;BIR/PR,MLM - UPDATE ORDER STATUS AFTER PATIENT SELECTION ;Jul 02, 2018@09:29
  1. ;;5.0;INPATIENT MEDICATIONS;**15,38,58,110,181,275,304,373**;16 DEC 97;Build 3
  1. ;
  1. ; Reference to ^PS(55 is supported by DBIA 2191
  1. ;
  1. ENNA ; Inpatient entry point.
  1. D:$D(XRTL) T0^%ZOSV
  1. D NOW^%DTC S PSFDT=%,PS=0 D L D:'$G(PSIVRD) PEND
  1. I $D(XRT0) S XRTN="PSIVACT" D T1^%ZOSV
  1. Q
  1. ;
  1. ENNB ; Ask profile type, gather orders.
  1. D NOW^%DTC S PSFDT=%,PS=0 K ^TMP("PSIV",$J),^TMP("PSJPRO",$J)
  1. S PSIVNV=$S(+PSJSYSU=1:"ANIV",+PSJSYSU=3:"APIV",1:"")
  1. D @P("PT") D:'$G(PSIVRD) PEND
  1. I P("PT")="L",$D(XRT0) S XRTN="PSIVACT" D T1^%ZOSV
  1. Q
  1. ;
  1. L ; Long profile
  1. S:'$D(PSJSYSU) PSJSYSU=""
  1. F ON=0:0 K Y S ON=$O(^PS(55,DFN,"IV",+ON)) Q:'ON D SETP
  1. Q
  1. ;
  1. S ; Short profile.
  1. S PSJDCEXP=$$RECDCEXP^PSJP()
  1. I '+$P(PSJDCEXP,U,2) S $P(PSJDCEXP,U,2)=PSFDT
  1. F PSIVDT=$P($G(PSJDCEXP),U,2):0 S PSIVDT=$O(^PS(55,DFN,"IV","AIS",PSIVDT)) Q:'PSIVDT!(PSIVDT'=+PSIVDT) F ON=0:0 S ON=$O(^PS(55,DFN,"IV","AIS",PSIVDT,+ON)) Q:'ON S ON=ON_"V",P(17)=$P($G(^PS(55,DFN,"IV",+ON,0)),U,17) D ACTO
  1. I +PSJSYSU=3 S PSIVNV="APIV" D NVACT K PSIVNV
  1. Q
  1. ;
  1. NVACT ; Non-verified but have active status
  1. NEW ON S PSGP=DFN ;added PSGP #373
  1. F ON=0:0 S ON=$O(^PS(55,PSIVNV,DFN,ON)) Q:'ON D
  1. . N CLIN,CLINSORT,SORT,PSIVSTAT,CLINSORT S PSIVSTAT="A"
  1. . S CLIN=$$CLINIC^PSJO1(PSGP,ON) I $L(CLIN)>1 S CLINSORT=$$CLINSORT^PSJO1("A") S PSIVSTAT="Cz^"_CLIN_"^"_CLINSORT_"^A"
  1. . I $P($G(^PS(55,DFN,"IV",ON,0)),U,17)="E",($P($G(^(.2)),U,4)="D") S ^TMP("PSIV",$J,PSIVSTAT,9999999999-ON)=""
  1. Q
  1. ;
  1. PEND ; Get pending and non-verified orders from 53.1
  1. N PSJCOM,PSJCOM1 S (PSJCOM,PSJCOM1)=0,PSGP=DFN ;added PSGP #373
  1. F ON=0:0 S ON=$O(^PS(53.1,"AS","P",DFN,ON)) Q:'ON D S PSJCOM1=PSJCOM
  1. . NEW X S X=$P($G(^PS(53.1,ON,.2)),U,4),X=$S(X="S":1,X="A":2,X="R":3,X="P":4,1:5)
  1. . S PSJCOM=$P($G(^PS(53.1,ON,.2)),U,8) I PSJCOM Q:'$$COMCHK^PSJO1(PSJCOM,2) Q:PSJCOM=PSJCOM1
  1. . N CLIN,CLINSORT,SORT,PSIVSTAT,CLINSORT S PSIVSTAT=$S('PSJCOM:"P",1:"PD")
  1. . S CLIN=$$CLINIC^PSJO1(PSGP,ON_"P") I $L(CLIN)>1 S CLINSORT=$$CLINSORT^PSJO1("P") S PSIVSTAT="Cz^"_CLIN_"^"_CLINSORT_"^"_PSIVSTAT
  1. . I $G(^PS(53.1,ON,0)),$P(^PS(53.1,ON,0),U,4)'="U" S ^TMP("PSIV",$J,PSIVSTAT,X_9999999999-ON)=""
  1. F ON=0:0 S ON=$O(^PS(53.1,"AS","N",DFN,ON)) Q:'ON D S PSJCOM1=PSJCOM
  1. . NEW X S X=$P($G(^PS(53.1,ON,.2)),U,4),X=$S(X="S":1,X="A":2,X="R":3,X="P":4,1:5)
  1. . S PSJCOM=$P($G(^PS(53.1,ON,.2)),U,8) I PSJCOM Q:'$$COMCHK^PSJO1(PSJCOM,2) Q:PSJCOM=PSJCOM1
  1. . N CLIN,PSIVSTAT,CLINSORT,SORT S PSIVSTAT=$S('PSJCOM:"N",1:"ND")
  1. . S CLIN=$$CLINIC^PSJO1(PSGP,ON_"P") I (CLIN]"") S CLINSORT=$$CLINSORT^PSJO1("P") S PSIVSTAT="Cz^"_CLIN_"^"_CLINSORT_"^"_$S('PSJCOM:"N",1:"ND")
  1. . I $G(^PS(53.1,ON,0)),$P(^PS(53.1,ON,0),U,4)'="U" S ^TMP("PSIV",$J,PSIVSTAT,X_9999999999-ON)=""
  1. .; S:$P(^PS(53.1,ON,0),U,4)'="U" ^TMP("PSIV",$J,"P",X_9999999999-ON)=""
  1. ;
  1. QUIT ; Kill and exit.
  1. K PSIVCWD,PSIVFLAG,PSIVWD,PSDFN,PSON1,PSFDT,YHOLD,JJ,XHOLD
  1. Q
  1. ;
  1. SETP ; Get partial P array,
  1. S ON=ON_"V",Y=$G(^PS(55,DFN,"IV",+ON,0)) F X=2,3,17,21 S P(X)=$P(Y,U,X)
  1. S P(2)=+P(2),P(3)=+P(3) S Y(P(2))="",Y(P(3))=""
  1. I P(2),P(3),P(17)'="P" D CHK
  1. Q
  1. ;
  1. CHK ; Check if order is active or expired and save accordingly.
  1. N CLIN,PSIVSTAT,CLINSORT,SORT S PSIVSTAT="A",PSGP=DFN ;373 added PSGP
  1. S CLIN=$$CLINIC^PSJO1(PSGP,ON) I CLIN]"" S CLINSORT=$$CLINSORT^PSJO1(PSIVSTAT) S PSIVSTAT="Cz^"_CLIN_"^"_CLINSORT_"^A"
  1. S PS=PS+1 I P(17)="H" S ^TMP("PSIV",$J,PSIVSTAT,9999999999-ON)="" Q
  1. I $O(Y(PSFDT))=P(3) D ACTO Q
  1. I $O(Y(PSFDT))="" D NACTO Q
  1. S:"ARO"[P(17) ^TMP("PSIV",$J,PSIVSTAT,9999999999-ON)="" S:"ED"[P(17) ^TMP("PSIV",$J,"X",9999999999-ON)="" S:"E"[P(17) PSIVREA="A",$P(^PS(55,DFN,"IV",+ON,0),U,17)="A",PS("A",9999999999-ON)=""
  1. Q
  1. ;
  1. ACTO ; Active orders
  1. ;I "AE"[P(17) S ^TMP("PSIV",$J,"A",9999999999-ON)="" S:P(17)="E" $P(^PS(55,DFN,"IV",+ON,0),U,17)="A" Q ;;mv-not sure why setting status back to "A"???
  1. N CLINSORT,SORT,CLIN,PSIVSTAT S PSIVSTAT="A",PSGP=DFN ;added PSGP #373
  1. S CLIN=$$CLINIC^PSJO1(PSGP,ON) I (CLIN]"") S CLINSORT=$$CLINSORT^PSJO1(PSIVSTAT) S PSIVSTAT="Cz^"_CLIN_"^"_CLINSORT_"^A"
  1. I ($P(PSIVSTAT,"^")="Cz") S:("DE"[P(17)) PSIVSTAT="RD" S ^TMP("PSIV",$J,PSIVSTAT,9999999999-ON)="" Q
  1. I "A"[P(17) S ^TMP("PSIV",$J,PSIVSTAT,9999999999-ON)="" Q
  1. I "HOR"[P(17) S ^TMP("PSIV",$J,PSIVSTAT,9999999999-ON)="" Q
  1. I "DE"[P(17) S ^TMP("PSIV",$J,"RD",9999999999-ON)=""
  1. Q
  1. ;
  1. NACTO ; Inactive orders
  1. ;I "AER"[P(17) S ^TMP("PSIV",$J,"X",9999999999-ON)="" I "AR"[P(17) S $P(^PS(55,DFN,"IV",+ON,0),U,17)="E" D EXPIR^PSIVOE Q
  1. N CLIN,PSIVSTAT,SORT,CLINSORT S PSIVSTAT="",PSGP=DFN ;added PSGP #373
  1. S CLIN=$$CLINIC^PSJO1(PSGP,ON)
  1. I "AER"[P(17) D
  1. . Q:$P(^PS(55,DFN,"IV",+ON,0),U,3)="" S PSIVSTAT="A"
  1. . I +PSJSYSU=3,($P($G(^PS(55,DFN,"IV",+ON,.2)),U,4)="D"),'+$P($G(^(4)),U,4) D Q
  1. .. I (CLIN]"") S CLINSORT=$$CLINSORT^PSJO1(PSIVSTAT) S PSIVSTAT="Cz^"_CLIN_"^"_CLINSORT_"^"_PSIVSTAT
  1. .. S ^TMP("PSIV",$J,PSIVSTAT,9999999999-ON)=""
  1. . S PSIVSTAT="X" S:(CLIN]"") CLINSORT=$$CLINSORT^PSJO1(PSIVSTAT) S:($G(CLINSORT)]"") PSIVSTAT="Cz^"_CLIN_"^"_CLINSORT_"^"_PSIVSTAT D
  1. .. S ^TMP("PSIV",$J,PSIVSTAT,9999999999-ON)=""
  1. I "AR"[P(17) S $P(^PS(55,DFN,"IV",+ON,0),U,17)="E" D EXPIR^PSIVOE
  1. I "OD"[P(17) S PSIVSTAT="X" S:(CLIN]"") CLINSORT=$$CLINSORT^PSJO1(PSIVSTAT) S:($G(CLINSORT)]"") PSIVSTAT="Cz^"_CLIN_"^"_CLINSORT_"^"_PSIVSTAT D
  1. .S ^TMP("PSIV",$J,PSIVSTAT,9999999999-ON)=""
  1. Q
  1. ;
  1. DCOR ; Auto-cancel IV orders
  1. ;NEED TO NEW VARIABLES LATER.
  1. NEW DA,DIR,DG,ON,ON55,P,PSIVAC,PSIVACT,PSIVLN,PSIVREA,PSIVRES,PSGALO,PSGP,PSJDCDT,PSJIVDCF,PSJIVON,PSJIVORF,PSJORF,VA,VADM,VAERR
  1. S PSGP=DFN,PSIVRES="Auto DC due to Surgery Package"
  1. D NOW^%DTC S PSJDCDT=+%
  1. D ENIV^PSJADT0
  1. Q