source: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVACT.m@ 623

Last change on this file since 623 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.7 KB
Line 
1PSIVACT ;BIR/PR,MLM-UPDATE ORDER STATUS AFTER PATIENT SELECTION ;16 Jul 98 / 12:51 PM
2 ;;5.0; INPATIENT MEDICATIONS ;**15,38,58,110**;16 DEC 97
3 ;
4 ; Reference to ^PS(55 is supported by DBIA 2191
5 ;
6ENNA ; Inpatient entry point.
7 D:$D(XRTL) T0^%ZOSV
8 D NOW^%DTC S PSFDT=%,PS=0 D L D:'$G(PSIVRD) PEND
9 I $D(XRT0) S XRTN="PSIVACT" D T1^%ZOSV
10 Q
11 ;
12ENNB ; Ask profile type, gather orders.
13 D NOW^%DTC S PSFDT=%,PS=0 K ^TMP("PSIV",$J),^TMP("PSJPRO",$J)
14 S PSIVNV=$S(+PSJSYSU=1:"ANIV",+PSJSYSU=3:"APIV",1:"")
15 ;D @P("PT") D:PSIVNV]"" NVACT D:'$G(PSIVRD) PEND
16 D @P("PT") D:'$G(PSIVRD) PEND
17 I P("PT")="L",$D(XRT0) S XRTN="PSIVACT" D T1^%ZOSV
18 Q
19 ;
20L ; Long profile
21 S:'$D(PSJSYSU) PSJSYSU=""
22 F ON=0:0 K Y S ON=$O(^PS(55,DFN,"IV",+ON)) Q:'ON D SETP
23 Q
24 ;
25S ; Short profile.
26 F PSIVDT=PSFDT:0 S PSIVDT=$O(^PS(55,DFN,"IV","AIS",PSIVDT)) Q:'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
27 I +PSJSYSU=3 S PSIVNV="APIV" D NVACT K PSIVNV
28 Q
29 ;
30NVACT ; Non-verified but have active status
31 NEW ON
32 F ON=0:0 S ON=$O(^PS(55,PSIVNV,DFN,ON)) Q:'ON D
33 . I $P($G(^PS(55,DFN,"IV",ON,0)),U,17)="E",($P($G(^(.2)),U,4)="D") S ^TMP("PSIV",$J,"A",9999999999-ON)=""
34 Q
35 ;
36PEND ; Get pending and non-verified orders from 53.1
37 N PSJCOM,PSJCOM1 S (PSJCOM,PSJCOM1)=0
38 F ON=0:0 S ON=$O(^PS(53.1,"AS","P",DFN,ON)) Q:'ON D S PSJCOM1=PSJCOM
39 . 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)
40 . S PSJCOM=$P($G(^PS(53.1,ON,.2)),U,8) I PSJCOM Q:'$$COMCHK^PSJO1(PSJCOM,2) Q:PSJCOM=PSJCOM1
41 . I $G(^PS(53.1,ON,0)),$P(^PS(53.1,ON,0),U,4)'="U" S ^TMP("PSIV",$J,$S('PSJCOM:"P",1:"PD"),X_9999999999-ON)=""
42 F ON=0:0 S ON=$O(^PS(53.1,"AS","N",DFN,ON)) Q:'ON D S PSJCOM1=PSJCOM
43 . 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)
44 . S PSJCOM=$P($G(^PS(53.1,ON,.2)),U,8) I PSJCOM Q:'$$COMCHK^PSJO1(PSJCOM,2) Q:PSJCOM=PSJCOM1
45 . I $G(^PS(53.1,ON,0)),$P(^PS(53.1,ON,0),U,4)'="U" S ^TMP("PSIV",$J,$S('PSJCOM:"N",1:"ND"),X_9999999999-ON)=""
46 .; S:$P(^PS(53.1,ON,0),U,4)'="U" ^TMP("PSIV",$J,"P",X_9999999999-ON)=""
47 ;
48QUIT ; Kill and exit.
49 K PSIVCWD,PSIVFLAG,PSIVWD,PSDFN,PSON1,PSFDT,YHOLD,JJ,XHOLD
50 Q
51 ;
52SETP ; Get partial P array,
53 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)
54 S P(2)=+P(2),P(3)=+P(3) S Y(P(2))="",Y(P(3))=""
55 I P(2),P(3),P(17)'="P" D CHK
56 Q
57 ;
58CHK ; Check if order is active or expired and save accordingly.
59 S PS=PS+1 I P(17)="H" S ^TMP("PSIV",$J,"A",9999999999-ON)="" Q
60 I $O(Y(PSFDT))=P(3) D ACTO Q
61 I $O(Y(PSFDT))="" D NACTO Q
62 S:"ARO"[P(17) ^TMP("PSIV",$J,"A",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)=""
63 Q
64 ;
65ACTO ; Active orders
66 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
67 I "HOR"[P(17) S ^TMP("PSIV",$J,"A",9999999999-ON)="" Q
68 I "D"[P(17) S ^TMP("PSIV",$J,"X",9999999999-ON)=""
69 Q
70 ;
71NACTO ; Inactive orders
72 ;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
73 I "AER"[P(17) D
74 . Q:$P(^PS(55,DFN,"IV",+ON,0),U,3)=""
75 . I +PSJSYSU=3,($P($G(^PS(55,DFN,"IV",+ON,.2)),U,4)="D"),'+$P($G(^(4)),U,4) S ^TMP("PSIV",$J,"A",9999999999-ON)="" Q
76 . S ^TMP("PSIV",$J,"X",9999999999-ON)=""
77 I "AR"[P(17) S $P(^PS(55,DFN,"IV",+ON,0),U,17)="E" D EXPIR^PSIVOE
78 I "OD"[P(17) S ^TMP("PSIV",$J,"X",9999999999-ON)=""
79 Q
80 ;
81DCOR ; Auto-cancel IV orders
82 ;NEED TO NEW VARIABLES LATER.
83 NEW DA,DIR,DG,ON,ON55,P,PSIVAC,PSIVACT,PSIVLN,PSIVREA,PSIVRES,PSGALO,PSGP,PSJDCDT,PSJIVDCF,PSJIVON,PSJIVORF,PSJORF,VA,VADM,VAERR
84 S PSGP=DFN,PSIVRES="Auto DC due to Surgery Package"
85 D NOW^%DTC S PSJDCDT=+%
86 D ENIV^PSJADT0
87 Q
Note: See TracBrowser for help on using the repository browser.