source: FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORMAR.m@ 1800

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

initial load of FOIAVistA 6/30/08 version
File size: 5.5 KB
Line 
1PSJORMAR ;BIR/MV-CREATE AN ARRAY FOR THE MAR LABEL. ;19 Mar 99 / 9:33 AM
2 ;;5.0; INPATIENT MEDICATIONS ;**2,15,26,65**;16 DEC 97
3 ;
4 ; References to ^PS(55 supported by DBIA #2191.
5 ; References to ^PSD(58.8 supported by DBIA #2283.
6 ; References to ^PSI(58.1 supported by DBIA #2284.
7 ; Reference to ^VA(200 is supported by DBIA #10060.
8 ; Reference to ^VALM1 is supported by DBIA #10116.
9 ;
10MAR(DFN,ON,PT,MARLB,ACT) ;
11 ;Input
12 ; DFN : Patient's internal entry number
13 ; ON : Order number (ex: 53U (U/D), 14V (IV), 1000P (pending)
14 ; PT : =1 to print patient data on the right label.
15 ; : =0 will not print the patient data
16 ; MARLB : Array name
17 ; ACT : Action on order or null
18 ; :NW:NEW;DC:DISCONTINUE;HD:HOLD;RL:RELEASE HOLD
19 ;Output
20 ; MARLB(X): There are 5 lines print per label. An order may contain
21 ; : multiple labels.
22 ;
23 NEW NODE,TYPE
24 NEW C,DRG,DRGI,DRGN,DRGT,DRUGNAME,F,FIL,L,ND,P,PSGDT,PSGLAD
25 NEW PSGLAGE,PSGLBID,PSGLBS5,PSGLDESC,PSGLDOB,PSGLDT
26 NEW PSGLDX,PSGLFD,PSGLNF,PSGLOD,PSGLPID,PSGLPN,PSGLPR
27 NEW PSGLR,PSGLRB,PSGLRN,PSGLRPH,PSGLRTN,PSGLSD,PSGLSEX
28 NEW PSGLSI,PSGLSM,PSGLSSN,PSGLST,PSGLTM,PSGLTS,PSGLWD
29 NEW PSGLWG,PSGLWDN,PSGLWGN,PSGLWS,PSGMARGD,PSGOES
30 NEW PSGOP,PSGORD,PSGP,PSGS0XT,PSGS0Y,PSGST,PSGTOL
31 NEW PSGVADR,PSIVUP,PSJCONT,PSJOPC,PSJORIFN,PST,Q,QQ,S,SD
32 NEW STOP,T,TS,VA,X
33 NEW PSJPON,PSJROC,PSJF,PSJLDT
34 S (PSGP,PSGOP)=DFN,PSGORD=ON D ^PSGLPI
35 D NOW^%DTC S PSJLDT=$E(%,1,12)
36 I ON["P" S NODE(0)=$G(^PS(53.1,+ON,0)),TYPE=$P(NODE(0),U,4)
37 I $G(TYPE)="F"!(ON["V") D IV Q
38 S:ON["U" NODE(0)=$G(^PS(55,DFN,5,+ON,0))
39 I $G(ACT)="NW" D
40 .S PSJPON=$P(NODE(0),U,25) I $G(PSJPON)]"" D
41 ..S PSJROC=$S(PSJPON["U":$P(^PS(55,PSGP,5,+PSJPON,0),U,27),PSJPON["V":$P(^PS(55,PSGP,"IV",+PSJPON,2),U,9),1:$P(^PS(53.1,+PSJPON,0),U,27))
42 ..S PSJF=$S(PSJPON["U":"^PS(55,"_PSGP_",5,"_+PSJPON,PSJPON["V":"^PS(55,"_PSGP_",""IV"","_+PSJPON,1:"^PS(53.1,"_+PSJPON)
43 ..S:$G(PSJROC)]"" $P(@(PSJF_",7)"),U,1,2)=PSJLDT_"^"_$S(PSJROC="R":"R",1:"DE")
44 S PSJF=$S(ON["U":"^PS(55,"_PSGP_",5,"_+ON,1:"^PS(53.1,"_+ON)
45 I $G(ACT)]""&($G(ACT)'="NW") S $P(@(PSJF_",7)"),U,1,2)=PSJLDT_"^"_$S(ACT="DC":"D",ACT="HD":"H1",1:"H0")
46 D UD
47 Q
48IV ;
49 D ^PSJORMA2,TS
50 Q
51UD ;Gather data for U/D order.
52 ;S PSGOP=DFN,PSGORD=ON D ^PSGLPI
53 ;S PSGP(0)=PSGLPN,PSSN=PSGLSSN
54 I $G(NODE(0))="" D Q
55 . S MARLB(1)=PSGLPN_" "_PSGLSSN
56 . S MARLB(2)=""
57 . S MARLB(3)="Order #: "_ON_" does not exist."
58 . S MARLB(4)="Please check."
59 . S MARLB(5)=""
60 S F=$S(ON["U":"^PS(55,DFN,5,+ON,",1:"^PS(53.1,+ON,")
61 S NODE(2)=$G(@(F_"2)"))
62 S NODE(4)=$G(@(F_"4)"))
63 S NODE(7)=$G(@(F_"7)"))
64 S PSGLDT=+NODE(7),PSGLR=$P(NODE(7),U,2)
65 S PSGLRN=+NODE(4),PSGLRPH=$P(NODE(4),U,3)
66 S PSGLOD=$E($$ENDTC^PSGMI($P(NODE(0),U,14)),1,5)
67 S PSGLSD=$$BLANK^PSGMUTL(11),PSGLFD=$$BLANK^PSGMUTL(14)
68 I ON["U" D
69 . S PSGLSD=$$ENDTC1^PSGMI($P(NODE(2),U,2)),PSGLSD=$E(PSGLSD,1,5)_$E(PSGLSD,9,14)
70 . S PSGLFD=$$ENDTC1^PSGMI($P(NODE(2),U,4))
71 S PSGLST=$P(NODE(0),U,7),PST=$S(PSGLST="C"!(PSGLST="O"):PSGLST,PSGLST="OC":"OA",PSGLST="P":"OP",$P(NODE(2),"^")["PRN":"OR",1:"CR")
72 ;S (PSGLST,PST)=$P(NODE(0),U,7)
73 D TS^PSGMAR3($P(NODE(2),U,5))
74 I $P(NODE(0),U,22) S PSGLSI="*** NOT TO BE GIVEN ***"
75 E S PSGLSI=$G(@(F_"6)"))
76 I PSGLSI="",$P($G(@(F_"0)")),U,9)="P",$O(@(F_"12,0)")) S X=0 F S X=$O(@(F_"12,"_X_")")) Q:'X S Z=$G(^(X,0)),Y=$L(PSGLSI) S:Y+$L(Z)'>179 PSGLSI=PSGLSI_Z_" " I Y+$L(Z)>179 S PSGLSI="SEE PROVIDER COMMENTS"
77 S PSGLSM=$S('$P(NODE(0),U,5):0,$P(NODE(0),U,6):1,1:2)
78 N PSGNOW D NOW^%DTC S PSGNOW=% S (PSGLNF,PSGLWS)=0 F X=0:0 S X=$O(@(F_"1,"_X_")")) Q:'X!(PSGLWS) S Y=$G(^(X,0)) I $P(Y,U,3)>PSGNOW!'$P(Y,U,3) S PSGLWS=$S($D(^PSI(58.1,"D",+Y,+PSGLWD)):1,$D(^PSD(58.8,"D",+Y,+PSGLWD)):1,1:0)
79 S:'PSGLRN PSGLRN="_____" I PSGLRN,$D(^VA(200,+PSGLRN,0))#2 S X=^(0),X=$S($P(X,U,2)]"":$P(X,U,2),1:$P(X,U)),PSGLRN=$S(X'[",":X,1:$E(X,$F(X,","))_$E(X))
80 S:'PSGLRPH PSGLRPH="_____" I PSGLRPH,$D(^VA(200,+PSGLRPH,0))#2 S X=^(0),X=$S($P(X,U,2)]"":$P(X,U,2),1:$P(X,U)),PSGLRPH=$S(X'[",":X,1:$E(X,$F(X,","))_$E(X))
81 D MARLB^PSJORMA1(37)
82 S P(9)=$P(NODE(0),U,9),P(3)=$P(NODE(2),U,4)
83 ;
84TS ;Attach amdin times to the label.
85 ;D NOW^%DTC S PSGDT=$E(%,1,12),PSGLFD=$P(NODE(2),U,4)
86 D NOW^%DTC S PSGDT=$E(%,1,12)
87 I P(3)]"",$E(P(3),1,12)'>PSGDT D
88 . F X=1:1:5 S TS(X)="****"
89 . S TS(3)=$S(P(9)["D":"DC'D",1:"EX'D"),TS(0)=5
90 F X=0:0 S X=$O(MARLB(X)) Q:'X S MARLB(X)=$$SETSTR^VALM1("|"_$G(TS(X)),MARLB(X),43,9)
91 D:$G(PT) PT
92 Q
93 ;
94PT ;Hook up patient info to label
95 ;S MARLB(1)=$$SETSTR^VALM1(PSGLPN,MARLB(1),52,87)
96 S MARLB(1)=MARLB(1)_PSGLPN
97 S X=$S(PSGLRB]"":PSGLRB,1:"*NF*")
98 S MARLB(1)=$$SETSTR^VALM1(X,MARLB(1),(97-$L(X)),$L(X))
99 ;S MARLB(2)=$$SETSTR^VALM1(PSGLSSN,MARLB(2),52,17)
100 S MARLB(2)=MARLB(2)_PSGLSSN
101 S MARLB(2)=$$SETSTR^VALM1(PSGLDOB_" ("_PSGLAGE_")",MARLB(2),70,14)
102 S MARLB(2)=$$SETSTR^VALM1($S(PSGLTM]"":PSGLTM,1:"NOT FOUND"),MARLB(2),88,15)
103 S MARLB(3)=MARLB(3)_PSGLSEX
104 S MARLB(3)=$$SETSTR^VALM1("DX: "_PSGLDX,MARLB(3),65,($L(PSGLDX)+4))
105 S:PSGLDT MARLB(4)=MARLB(4)_$$ENDTC^PSGMI(PSGLDT)
106 S Y=PSGLR,X=$S(Y="NR":"RENEWAL ",Y="N":"NEW ",1:"")_"ORDER"
107 S Y=X_$S(Y="E":" EDITED",Y="DE":" DC'ED (EDIT)",Y["D":" DISCONTINUED",Y="H1":" ON HOLD",Y="H0":" OFF OF HOLD",Y="RE":" REINSTATED",1:"")
108 ;I PSGLFD]"",(PSGLFD'>PSGDT),(PSGLR'["D") S Y=Y_" (EXPIRED)"
109 I P(3)]"",(P(3)'>PSGDT),(PSGLR'["D") S Y=Y_" (EXPIRED)"
110 I Y="ORDER" S Y=""
111 ;;S:ON["P" Y=""
112 S MARLB(4)=$$SETSTR^VALM1(Y,MARLB(4),(97-$L(Y)),$L(Y))
113 S MARLB(5)=MARLB(5)_$S(PSGLWGN]"":$E(PSGLWGN,1,21),1:"NOT FOUND")
114 S X=$S(PSGLWDN]"":$E(PSGLWDN,1,21),1:"NOT FOUND")
115 S MARLB(5)=$$SETSTR^VALM1(X,MARLB(5),(97-$L(X)),$L(X))
116 Q
Note: See TracBrowser for help on using the repository browser.