source: FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJMUTL.m@ 811

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

initial load of FOIAVistA 6/30/08 version
File size: 6.3 KB
Line 
1PSJMUTL ;BIR/MV-UTLILITY USE FOR QUEUING... ;25 Nov 98 / 9:13 AM
2 ;;5.0; INPATIENT MEDICATIONS ;**8,21,31,160**;16 DEC 97;Build 12
3 ; References to ^PS(52.7 supported by DBIA #2173
4 ; Reference to ^ORRDI1 is supported by DBIA 4659
5 ; Reference to ^XTMP("ORRDI" is supported by DBIA 4660
6 ; Reference to ^GMRADPT supported by DBIA #10099
7SELDEV() ;*** Ask for device type for report to output to ***
8 K IOP,%ZIS,POP,IO("Q")
9 S %ZIS("A")="Select output device: ",%ZIS("B")="",%ZIS="Q"
10 D ^%ZIS S PSJSTOP=$S(POP:1,1:0) I POP W !,"** No device selected or Report printed **" D EXIT
11 Q $G(PSJSTOP)
12 ;
13SETSORTQ(XDESC,XSAVE,ZTRTN) ;Queue to sort. D SETDEV^PSJMUTL(X,Y)
14 N I,X
15 K IO("Q"),ZTSAVE,ZTDTH,ZTSK
16 S ZTDESC=XDESC,PSGIO=ION,ZTIO=""
17 S PSGIODOC="" I $G(IO("DOC"))]"" S PSGIODOC=IO("DOC")
18 F I=1:1 S X=$P(XSAVE,";",I) Q:X="" S ZTSAVE(X)=""
19 D ^%ZTLOAD
20 Q
21 ;
22SETPRTQ(XDESC,XSAVE,ZTRTN) ;Queue to printer. D SETPRTQ^PSJMUTL(X,Y)
23 N I,X
24 S ZTIO=PSGIO,ZTDESC=XDESC,ZTDTH=$H,%ZIS="QN",IOP=PSGIO
25 I $G(PSGIODOC)]"" S ZTIO=ZTIO_";"_PSGIODOC
26 F I=1:1 S X=$P(XSAVE,";",I) Q:X="" S ZTSAVE(X)=""
27 D ^%ZIS,^%ZTLOAD
28 Q
29 ;
30EXITDEV ;
31 I $E(IOST)="C",('$G(PSJSTOP)) K DIR W ! S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR
32 S:$D(ZTQUEUED) ZTREQ="@"
33 S IOP="HOME" D ^%ZISC
34 Q
35 ;
36PRTCHK(PGCT) ;
37 I $E(IOST)="C",PGCT K DIR W ! S DIR(0)="E" D ^DIR S:'Y PSJSTOP=1
38 I $D(ZTQUEUED),$$S^%ZTLOAD S (ZSTOP,PSJSTOP)=1
39 I $G(PSJSTOP) W !!?20,"...Report stopped at user request..." K DIR S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR
40 Q $G(PSJSTOP)
41 ;
42EXIT ;
43 K %,%H,%I,%ZIS,ZTDESC,ZTDTH,ZTIO,ZTSAVE,ZTRTN
44 W:$E(IOST)="C"&($Y) @IOF
45 S:$D(ZTQUEUED) ZTREQ="@"
46 S IOP="HOME" D ^%ZISC
47 Q
48ATS(REG,EXP,LN) ;
49 ;*** Split allergies and adverse reactions from the allergy package.
50 ;*** INPUT ***
51 ;*** REG - the length the allergies and adv. reactions display on 1 pg.
52 ;*** EXP - the length that will display on extra page.
53 ;*** LN - for MAR, allergies and reations are display on 1 line.
54 ; - for Profile, display allergies and reactions on separate ln.
55 ;*** OUTPUT ***
56 ;*** PSGALG - Allergies array.
57 ;*** PSGADR - Adverse Reactions array.
58 ;***** rlw - 1/16/96 added PSGVALG for verified allergies and PSGVADR for verified adverse reactions.
59GETGMRA ;
60 N GMRA,GMRAL,GMRANKA,GMRAOTH,LEN,X,Y,TYPE,NAME,SORT,ALG,VALG,ADR,VADR,ALGCT,VALGCT,ADRCT,VADRCT,VERIFIED
61 K PSGADR,PSGALG,PSGVADR,PSGVALG
62 S (VALGCT,ALGCT,VADRCT,ADRCT,PSGVALG,PSGALG,PSGVADR,PSGADR)=0,(PSGVALG(1),PSGALG(1),PSGVADR(1),PSGADR(1))=""
63 S:'$G(DFN)&$G(PSGP) DFN=PSGP
64 S:'$G(PSGP)&$G(DFN) PSGP=DFN
65 S GMRA="0^0^111",DFN=PSGP D ^GMRADPT
66 I $G(PSJWHERE)="PSJLMUTL" S PSJGMRAL=GMRAL Q:(GMRAL="")!(GMRAL=0)
67 I GMRAL="" S:$E(IOST)="P" (PSGVALG,PSGALG,PSGVADR,PSGADR)=20,$P(PSGALG(1),"_",20)=" ",(PSGVALG(1),PSGADR(1),PSGVADR(1))=PSGALG(1) Q
68 I GMRAL=0 S (PSGVALG,PSGALG)=3,(PSGALG(1),PSGVALG(1))="NKA" S:$E(IOST)="P" PSGADR=20,$P(PSGADR(1),"_",20)=" ",PSGVADR=20,PSGVADR(1)=PSGADR(1) Q
69 ;
70SORT ;*** Set up the allergies and adv. reactions arrays.
71 F X=0:0 S X=$O(GMRAL(X)) Q:'X S TYPE=$P(GMRAL(X),U,5),NAME=$P(GMRAL(X),U,2),VERIFIED=$P(GMRAL(X),U,4) D
72 .S SORT=$P(GMRAL(X),U,7),SORT=$S(SORT="D":1,SORT="DF":2,SORT="DFO":3,SORT="DO":4,SORT="F":5,SORT="FO":6,1:7)
73 .S:(TYPE=0)&(VERIFIED=1) PSGVALG=PSGVALG+$L(NAME),VALGCT=VALGCT+1,VALG(SORT_NAME)=""
74 .S:(TYPE=0)&(VERIFIED=0) PSGALG=PSGALG+$L(NAME),ALGCT=ALGCT+1,ALG(SORT_NAME)=""
75 .S:(TYPE>0)&(VERIFIED=0) PSGADR=PSGADR+$L(NAME),ADRCT=ADRCT+1,ADR(SORT_NAME)=""
76 .S:(TYPE>0)&(VERIFIED=1) PSGVADR=PSGVADR+$L(NAME),VADRCT=VADRCT+1,VADR(SORT_NAME)=""
77 ;
78CALLEN ;*** Calculate the total length for allergy and adv.reaction arrays.
79 S:VALGCT>1 PSGVALG=PSGVALG+((VALGCT-1)*2) S:$E(IOST)="P"&'PSGVALG PSGVALG=20,$P(PSGVALG(1),"_",20)=" "
80 S:ALGCT>1 PSGALG=PSGALG+((ALGCT-1)*2) S:$E(IOST)="P"&'PSGALG PSGALG=20,$P(PSGALG(1),"_",20)=" "
81 S:VADRCT>1 PSGVADR=PSGVADR+((VADRCT-1)*2) S:$E(IOST)="P"&'PSGVADR PSGVADR=20,$P(PSGVADR(1),"_",20)=" "
82 S:ADRCT>1 PSGADR=PSGADR+((ADRCT-1)*2) S:$E(IOST)="P"&'PSGADR PSGADR=20,$P(PSGADR(1),"_",20)=" "
83 S (VALGCT,ALGCT,VADRCT,ADRCT)=1
84 S:LN=1 LEN=$S((PSGALG+PSGVALG+PSGADR+PSGVADR)>REG:EXP,1:REG)
85 S:LN>1 LEN=$S($S(PSGALG>REG:1,PSGADR>REG:1,PSGVALG>REG:1,PSGVADR>REG:1,1:0):EXP,1:REG)
86 ;
87SETARRAY ;*** Concatenate allergies and adv. reaction together into display len.
88 S (X,Y)="" F S X=$O(VALG(X)) Q:X="" S:LEN'>($L(Y)+$L(X)+1) PSGVALG(VALGCT)=Y_",",Y="",VALGCT=VALGCT+1 S:Y]"" Y=Y_", " S Y=Y_$E(X,2,$L(X))
89 S:$G(PSGVALG(VALGCT))="" PSGVALG(VALGCT)=Y
90 S (X,Y)="" F S X=$O(ALG(X)) Q:X="" S:LEN'>($L(Y)+$L(X)+1) PSGALG(ALGCT)=Y_",",Y="",ALGCT=ALGCT+1 S:Y]"" Y=Y_", " S Y=Y_$E(X,2,$L(X))
91 S:$G(PSGALG(ALGCT))="" PSGALG(ALGCT)=Y
92 S (X,Y)="" F S X=$O(ADR(X)) Q:X="" S:LEN'>($L(Y)+$L(X)+1) PSGADR(ADRCT)=Y_",",Y="",ADRCT=ADRCT+1 S:Y]"" Y=Y_", " S Y=Y_$E(X,2,$L(X))
93 S:$G(PSGADR(ADRCT))="" PSGADR(ADRCT)=Y
94 S (X,Y)="" F S X=$O(VADR(X)) Q:X="" S:LEN'>($L(Y)+$L(X)+1) PSGVADR(VADRCT)=Y_",",Y="",VADRCT=VADRCT+1 S:Y]"" Y=Y_", " S Y=Y_$E(X,2,$L(X))
95 S:$G(PSGVADR(VADRCT))="" PSGVADR(VADRCT)=Y
96 Q
97 ;
98NAMENEED(DRGX,LEN,NEED) ;*** Return the number of lines needed.
99 ;*
100 ;* DRG - AD/SOL LEN - Drug name length NEED - line needed
101 ;*
102 S NEED=0
103 F X=0:0 S X=$O(DRG(DRGX,X)) Q:'X D NAME^PSIVUTL(DRG(DRGX,X),LEN,.NAME,1) S NEED=NEED+$S($G(NAME(2))]"":2,1:1) I DRGX="SOL",$P(^PS(52.7,+DRG(DRGX,X),0),U,4)]"" S NEED=NEED+1
104 Q
105RAD ;
106 I $T(HAVEHDR^ORRDI1)']"" Q
107 I '$$HAVEHDR^ORRDI1 Q
108 S PSGRALG=1,PSGRALG(1)="No remote data available"
109 I $D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) G REMOTE2
110 I $T(GET^ORRDI1)]"" D GET^ORRDI1(DFN,"ART") D
111 . N S1,REAC,A,FILE,LEN K ^TMP($J,"PSJART")
112 . S S1=0,LEN=57,PSGRALG=1,PSGRALG(1)="" F S S1=$O(^XTMP("ORRDI","ART",DFN,S1)) Q:'S1 D
113 .. S A=$G(^XTMP("ORRDI","ART",DFN,S1,"REACTANT",0)),REAC=$P(A,"^",2),FILE=$P($P(A,"^",3),"99VA",2)
114 .. I FILE'=50.6,FILE'=120.82,FILE'=50.605,FILE'=50.416 Q
115 .. S ^TMP($J,"PSJART",REAC)=""
116 . S REAC="" F S REAC=$O(^TMP($J,"PSJART",REAC)) Q:REAC="" D
117 .. I $L(PSGRALG(PSGRALG))+$L(REAC)<LEN S PSGRALG(PSGRALG)=PSGRALG(PSGRALG)_REAC_", " Q
118 .. S PSGRALG=PSGRALG+1,PSGRALG(PSGRALG)=" "_REAC_", ",LEN=77
119 . S A=$L(PSGRALG(PSGRALG)) I $E(PSGRALG(PSGRALG),A-1,A)=", " S PSGRALG(PSGRALG)=$E(PSGRALG(PSGRALG),1,A-2)
120REMOTE2 ;
121 S ^TMP("PSJALL",$J,PSJLN,0)=" Remote: "_$G(PSGRALG(1)),PSJLN=PSJLN+1
122 F I=2:1:PSGRALG S ^TMP("PSJALL",$J,PSJLN,0)=PSGRALG(I),PSJLN=PSJLN+1
123 Q
Note: See TracBrowser for help on using the repository browser.