source: FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGMMIV.m@ 631

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

initial load of FOIAVistA 6/30/08 version
File size: 7.8 KB
Line 
1PSGMMIV ;BIR/MV-IV ORDER FOR THE 7/14 DAY MAR. ;25 Nov 98 / 9:24 AM
2 ;;5.0; INPATIENT MEDICATIONS ;**20,21,58,111,131,145**;16 DEC 97;Build 17
3 ;
4 ; Reference to ^PS(52.7 supported by DBIA #2173.
5 ; Reference to ^PS(55 supported by DBIA #2191.
6 ;
7START ;*** Read IV orders
8 NEW MULTIPG
9 S ON=""
10 F PSGMARED=PSGMARSD-.0001:0 S PSGMARED=$O(^PS(55,PSGP,"IV","AIT",PST,PSGMARED)) Q:'PSGMARED F S ON=$O(^PS(55,PSGP,"IV","AIT",PST,PSGMARED,ON)) Q:ON="" D IV
11 Q
12IV ;*** Sort IV orders for 24 Hrs, 7/14 Day MAR.
13 K DRG,P N X,ON55,PSJLABEL S DFN=PSGP,PSJLABEL=1 D GT55^PSIVORFB
14 Q:P(2)>PSGMARFD
15 S X=$P(P("MR"),U,2) Q:XTYPE=2&(X["IV") Q:XTYPE=3&(PST="S")&'($S(X="IV":1,X="IVPB":1,1:0))
16 S QST=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3))
17 S QST=$S(P(9)["PRN":"OVP",QST="O":"OVO",1:"CV")_XTYPE
18 Q:(PSGMARS=2&(QST["C"))
19 Q:(PSGMARS=1&(QST["O"))
20 N PSGMARWC ;DEM (05/30/2006) - PSGMARWC is used to preserve original value of PSGMARWN (patient location) in case location is changed by an order with a clinic location.
21 S PSGMARWC=PSGMARWN
22 I $G(DRG) S X=$S($G(DRG("AD",1)):DRG("AD",1),1:$G(DRG("SOL",1))),X=$E($P(X,U,2),1,20)_U_+ON_"V" D
23 . N A
24 . S A=$G(^PS(55,PSGP,"IV",+ON,"DSS")) I $P(A,"^")]"" S PSGMARWN="C!"_$P(A,"^") I $G(SUB1)]"",$G(SUB2)]"",'$D(^TMP($J,TM,PSGMARWN,SUB1,SUB2)) D
25 . . N X,Y
26 . . D SPN^PSGMMAR0
27 . . Q
28 . . ;
29 . I PSGSS="P" S ^TMP($J,PPN,PSGMARWN,$S(+PSGMSORT:$E(QST,1),1:QST),X)="" Q ;DAM 5-01-07 Print by PATIENT
30 . I PSGSS="L" Q:((PSGINWDG="")&(PSGMARWN'["C!")) S ^TMP($J,PPN,PSGMARWN,$S(+PSGMSORT:$E(QST,1),1:QST),X)="" Q ;DAM 5-01-07 Print by clinic group
31 . I PSGSS="C" Q:((PSGINWD="")&(PSGMARWN'["C!")) I ((PSGMARWN[PSGCLNC)!(PSGMARWN'["C!")) S ^TMP($J,PPN,PSGMARWN,$S(+PSGMSORT:$E(QST,1),1:QST),X)="" Q ;DAM 5-01-07 Print by Clinic
32 . ;
33 . ;DAM 5-01-07 Set up XTMP global where location and patient names are switched for printing by WARD/PATIENT or WARD GROUP/PATIENT
34 . I '$G(PSGREP) N PSGDEM1 S PSGDEM1=X D ;transfer contents of patient drug information contained in "X" above to a new variable temporarily
35 . . S PSGREP="PSGM_"_$J
36 . . S X1=DT,X2=1 D C^%DTC K %,%H,%T
37 . . S ^XTMP(PSGREP,0)=X_U_DT
38 . I PSGRBPPN="P",PSGSS="W" Q:((PSGINCL="")&(PSGMARWN["C!")) D ;Construct XTMP global for printing by WARD and sort by PATIENT
39 . . S ^XTMP(PSGREP,TM,PPN,PSGMARWN,PSJPRB,$S(+PSGMSORT:$E(QST,1),1:QST),PSGDEM1)=""
40 . . D SPN^PSGMMAR0
41 . I PSGRBPPN="P",PSGSS="G" Q:((PSGINCLG="")&(PSGMARWN["C!")) D ;Construct XTMP global for printing by WARD GROUP and sort by PATIENT
42 . . S ^XTMP(PSGREP,TM,PPN,PSGMARWN,PSJPRB,$S(+PSGMSORT:$E(QST,1),1:QST),PSGDEM1)=""
43 . . D SPN^PSGMMAR0
44 . S X=$G(PSGDEM1) ;Return value of X from PSGDEM1 back to X
45 . ;
46 . I PSGRBPPN="R",PSGSS="W" Q:((PSGINCL="")&(PSGMARWN["C!")) D ;Construct TMP global for printing by WARD and sort by ROOM/BED
47 . . S ^TMP($J,TM,PSGMARWN,PSJPRB,PPN,$S(+PSGMSORT:$E(QST,1),1:QST),X)=""
48 . I PSGRBPPN="R",PSGSS="G" Q:((PSGINCLG="")&(PSGMARWN["C!")) D ;Construct TMP global for printing by WARD GROUP and sort by ROOM/BED
49 . . S ^TMP($J,TM,PSGMARWN,PSJPRB,PPN,$S(+PSGMSORT:$E(QST,1),1:QST),X)=""
50 . ;End DAM modifications 5-01-07
51 . ;
52 S:PSGMARWN'=PSGMARWC PSGMARWN=PSGMARWC
53 Q
54IVPRN ;*** Set ^tmp to store IV orders that have schedule of PRN.
55 K P,DRG NEW ON55,CHEMO,TXT,PSJLABEL
56 S ON=$P(DAOO,U,2),DFN=$P(PN,U,2),PSJLABEL=1
57 ;* D:PST'["Z" GT55^PSIVORFB
58 ;* I PST["Z" D GT531^PSIVORFA(DFN,ON)
59 D:ON["V" GT55^PSIVORFB
60 D:ON["P" GT531^PSIVORFA(DFN,ON)
61 D SETVAR,SETLTRT
62 ;the two naked references below refer to the full reference to the right of the = sign
63 S ^(1)=$G(^TMP($J,"1PRN",PG,LAB,1))_UP_" | |"
64 S ^(2)=$G(^TMP($J,"1PRN",PG,LAB,2))_UP_$E(P("LOG"),1,5)_" |",LN=3
65 ;* S:PST["Z" ^(2)=^(2)_"P E N D I N G"
66 ;* S:PST'["Z" ^(2)=^(2)_$E(P(2),1,5)_$E(P(2),9,14)_" |"_P(3)
67 ;Naked reference below refers to ^TMP($J,"1PRN",PG,LAB,2)
68 S:ON["P" ^(2)=^(2)_"P E N D I N G"
69 ;Naked reference below refers to ^TMP($J,"1PRN",PG,LAB,2)
70 S:ON["V" ^(2)=^(2)_$E(P(2),1,5)_$E(P(2),9,14)_" |"_P(3)
71 ;Naked reference below refers to ^TMP($J,"1PRN",PG,LAB,2)
72 S ^(2)=$$SETSTR^VALM1("("_$E(PSGP(0))_$E(PSSN,8,12)_")",^(2),40,7)
73 F X=0:0 S X=$O(DRG("AD",X)) Q:'X S TXT=$$WRTDRG^PSIVUTL(DRG("AD",X),47) S:LN=3 TXT=TXT_$$SP(47-$L(TXT))_PSGST,PSGST="" D CHK(.TXT)
74 S TXT="in "
75 ;; F X=0:0 S X=$O(DRG("SOL",X)) Q:'X S TXT=TXT_$$WRTDRG^PSIVUTL(DRG("SOL",X),47) S:LN=3 TXT=TXT_$$SP(47-$L(TXT))_PSGST,PSGST="" D CHK(.TXT) S TXT=" "
76 F X=0:0 S X=$O(DRG("SOL",X)) Q:'X D
77 . S TXT=TXT_$$WRTDRG^PSIVUTL(DRG("SOL",X),47) S:LN=3 TXT=TXT_$$SP(47-$L(TXT))_PSGST,PSGST="" D CHK(.TXT) S TXT=" "
78 . S PSJPRT2=$P(^PS(52.7,+DRG("SOL",X),0),U,4) I PSJPRT2]"" S TXT=TXT_" "_PSJPRT2 S:LN=3 TXT=TXT_$$SP(47-$L(TXT))_PSGST,PSGST="" D CHK(.TXT) S TXT=" "
79 S TXT=$P(P("MR"),U,2)_" "_P(9)_" "_P(8) D CHK(.TXT)
80 I P(4)="C" S CHEMO="*CAUTION-CHEMOTHERAPY*" D:P("OPI")]"" CHK(CHEMO)
81 S Y1="" F Y=1:1:$L($P(P("OPI"),"^")," ") S Y1=Y1_$P($P(P("OPI"),"^")," ",Y)_" " I $L(Y1)>47 D CHK(Y1) S Y1=""
82 I $L(Y1)>28 D CHK(Y1) S Y1=""
83 I Y1<29,'(LN#6) S TXT=$S((P("OPI")=""&$D(CHEMO)):CHEMO,1:Y1),X=29-$L(TXT),TXT=TXT_$$SP(X)_INIT
84 E D S TXT=$$SP(29)_INIT,LN=LN+1
85 . ;the following three naked references below refer to the full references to the right of the = sign
86 . I LN=5 S ^(LN)=$G(^TMP($J,"1PRN",PG,LAB,LN))_UP_Y1
87 . E D:$L(Y1) CHK(Y1) F LN=LN:1:5 S ^(LN)=$G(^TMP($J,"1PRN",PG,LAB,LN))_UP_""
88 S ^(LN)=$G(^TMP($J,"1PRN",PG,LAB,LN))_UP_TXT
89 Q
90SETVAR ;***Initialize variables.
91 NEW TMSTR
92 F X="LOG",2,3 S:P(X) P(X)=$$ENDTC^PSGMI(P(X))
93 S PSGST=$S(P(9)["PRN":"P",P(2)=P(3):"O",1:"C"),TMSTR=P(11),PSGLFFD=PSGMARFD
94 D INITOPI^PSGMMIVC
95 ;;S INIT="RPH: "_PSGLRPH,INIT=INIT_$$SP(37-($L(INIT)+29))_"RN: "_PSGLRN
96 S INIT="RPH: "_PSGLRPH,INIT=INIT_$$SP(38-($L(INIT)+29))_"RN: "_PSGLRN
97 ;* S INIT="RPH: "_PSGLRPH_" RN: "_PSGLRN
98 ;* S INIT="RPH: "_$S(PSGLRPH]"":PSGLRPH_" ",1:"_____")_" RN: "_$S($G(PSGLRN)]"":PSGLRN,1:"_____")
99 ;*** If OPI<29 char, it is ok to put INITs in the same line.
100 ;*** If OPI=""&it's a Chemo order, warning & Inits prt on same line.
101 ;*** Add number lines needed for additives and solutions and 1 line
102 ;*** for infusion rate and 1 line for start/stop date.
103 ;*** Multiple labels can have up to 5 lines per label and the last
104 ;*** label can have up to 6 lines..
105 ;
106 NEW X S NAMENEED=0
107 F X="AD","SOL" D NAMENEED^PSJMUTL(X,47,.NEED) S NAMENEED=NAMENEED+NEED
108 S MULTIPG=0,NEED=1
109 ;* S X=($L(P("OPI"))>28)+1+(P("OPI")]""&(P(4)="C"))
110 ;* Find # of lines needed for OPI -- (($L(P("OPI"))\47)
111 ;* If the last line in OPI < 29 --(($L(P("OPI")#47)>28) include init.
112 S X=($L($P(P("OPI"),"^"))\47)+(($L($P(P("OPI"),"^"))#47)>28)+1+($P(P("OPI"),"^")]""&(P(4)="C"))
113 S X=(NAMENEED+X+2) S:X>5 NEED=((X-6)\5)+2
114 S:NEED>BL MULTIPG=1
115 Q
116CHK(TXT) ;
117 ;naked reference below refers to the full reference to the right of the = sign
118 I '(LN#6) S ^(LN)=$G(^TMP($J,"1PRN",PG,LAB,LN))_UP_"See next label for continuation",LN=1 D
119 . I PSGMAROC+1>(BL/2) D
120 . . I PSGMAROC=BL-1,MULTIPG D
121 . . .;naked reference below refers to the full reference to the right of the = sign
122 . . .F LN=LN:1:6 S ^(LN)=$G(^TMP($J,"1PRN",PG,LAB,LN))_UP_"" S:LN=3 ^(LN)=UP_"*** CONTINUE ON NEXT PAGE ***"
123 . . .S PG=PG+1,(LN,LT,RT)=1,(PSGMAROC,MULTIPG)=0 D LTRT^PSGMMAR3(.LT,"")
124 . . E D LTRT^PSGMMAR3(.RT,"^")
125 . E D LTRT^PSGMMAR3(.LT,"")
126 ;naked reference below refers to the full reference to the right of the = sign
127 S ^(LN)=$G(^TMP($J,"1PRN",PG,LAB,LN))_UP_TXT,LN=LN+1,TXT=""
128 Q
129SETLTRT ;*** Increment line number for left or right label on PRN sheet.
130 I (NEED+PSGMAROC)>BL S:PSGMAROC PG=PG+1,(LT,RT)=1,PSGMAROC=0
131 I NEED+PSGMAROC=BL D Q
132 . I PSGMAROC<(BL/2) D LTRT^PSGMMAR3(.LT,"")
133 . E D LTRT^PSGMMAR3(.RT,"^")
134 I PSGMAROC,((NEED+PSGMAROC)>(BL/2)) S PSGMAROC=$S(PSGMAROC>(BL/2):PSGMAROC,1:(BL/2)) D LTRT^PSGMMAR3(.RT,"^")
135 E D LTRT^PSGMMAR3(.LT,"")
136 Q
137SP(X) ;***Set up spaces need between info on TXT for the label.
138 N Y S $P(Y," ",X)=" "
139 Q $G(Y)
Note: See TracBrowser for help on using the repository browser.