source: FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGLOI.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.7 KB
Line 
1PSGLOI ;BIR/CML3-ORDER INFO (AND PRINT) FOR LABELS ;30 Apr 98 / 4:41 PM
2 ;;5.0; INPATIENT MEDICATIONS ;**7,44,58,110,111,138**;16 DEC 97
3 ;
4 ;Reference to ^PS(51.2 is supported by DBIA 2178.
5 ;Reference to ^PSD(58.8 is supported by DBIA 2283.
6 ;Reference to ^PSI(58.1 is supported by DBIA 2284.
7 ;Reference to ^PS(55 supported by DBIA #2191.
8 ;
9ENOI ;
10 S F="^PS("_$S(PSGORD["N":"53.1,",PSGORD["P":"53.1,",1:"55,"_PSGOP_",5,")_+PSGORD_","
11 ; the quit below corrects an error if the Order has been moved to 55
12 Q:'$D(@(F_"0)"))
13 S ND=$G(@(F_"0)")),PSGLPR=$P(ND,"^",2),PSGLMR=$P(ND,"^",3),PSGLST=$P(ND,"^",7),PSGLSTAT=$P(ND,"^",9),PSGLTD=$P(ND,"^",12),PSGLOD=$P(ND,"^",14),PSGLSM=$S('$P(ND,"^",5):0,$P(ND,"^",6):1,1:2),NG=$P(ND,"^",22)
14 S ND=$G(@(F_".2)")),PSGLDRG=$P(ND,"^"),PSGLDDA=+ND,PSGLDO=$P(ND,"^",2)
15 S PSGCLN=$S(F[53.1:$G(@(F_"""DSS"")")),1:$G(@(F_"8)"))) I PSGCLN]"" S PSGLWDN=$P(^SC($P(PSGCLN,"^"),0),"^")
16 ;
17SET ;
18 ; naked references below refer to full reference inside indirection @(F_"2)" for either file 53.1 or 55
19 K PSGLAT S ND=$G(@(F_"2)")),(PSGLSSD,PSGLSD)=$P(ND,"^",2),(PSGLFFD,PSGLFD)=$P(ND,"^",4),PSGLAT=$P(ND,"^",5),PSGLMN=$P(ND,"^",6),PSGLSCH=$P(ND,"^"),ND=$G(^(7)),PSGLDT=+ND,PSGLR=$P(ND,"^",2)
20 I PSGLST'="R",PSGLMN="D",PSGLAT="" S PSGLAT=$E($P(PSGLSD,".",2)_"0000",1,4)
21 I PSGLAT,PSGLSCH["@" S PSGLSCH=$P(PSGLSCH,"@")
22 S (PSGLAT(0),X)=0 I PSGLFD]"",PSGLFD'>PSGDT S (PSGLAT(0),X)=5,(PSGLAT(1),PSGLAT(2),PSGLAT(4),PSGLAT(5))="****",PSGLAT(3)=$S(PSGLSTAT["D":"DC'D",1:"EX'D")
23 E I $S(PSGLSTAT="P":1,PSGLSTAT="U":1,PSGLST="OC":1,PSGLST="P":1,1:PSGLSCH["PRN") S PSGLAT=""
24 E I PSGLAT S PSGLAT(0)=$L(PSGLAT,"-"),X=0 D
25 .F Q=1:1:5 S PSGLAT(Q)=""
26 .S Q=PSGLAT(0),Y=PSGLAT I Q=1 S PSGLAT(3)=$P(Y,"-") Q
27 .I Q=2 S PSGLAT(1)=$P(Y,"-"),PSGLAT(5)=$P(Y,"-",2) Q
28 .I Q=3 S PSGLAT(1)=$P(Y,"-"),PSGLAT(3)=$P(Y,"-",2),PSGLAT(5)=$P(Y,"-",3) Q
29 .F Q=1:1:PSGLAT(0) S X=X+1,PSGLAT(X)=$P(PSGLAT,"-",Q) I PSGLAT(0)<4 S X=X+1 S:Q<5 PSGLAT(X)=""
30 I X<5 F Q=X+1:1:5 S:'$G(PSGLAT(Q)) PSGLAT(Q)=""
31 I $G(DFN),$G(PSGORD) N PSGLREN S PSGLREN=+$$LASTREN^PSJLMPRI(DFN,PSGORD)
32 S ND=$G(@(F_"4)")),PSGLRN=+ND,PSGLRPH=+$P(ND,"^",3) N PSGLRNDT S PSGLRNDT=$P(ND,"^",2) I PSGLRNDT,$G(PSGLREN) I $G(PSGLREN)>PSGLRNDT S PSGLRN=0
33 I NG S PSGLSI="*** NOT TO BE GIVEN ***"
34 E S PSGLSI=$P($G(@(F_"6)")),"^") S:PSGLSI]"" PSGLSI=$$ENSET^PSGSICHK(PSGLSI)
35 ;* I PSGLSI="",$P(@(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=PSGLSI_$E(Z,1,177-Y)_"..." Q
36 ; naked references below refer to full reference inside indirection @(F_"2)" for either file 53.1 or 55
37 I PSGLSI="",$P(@(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" Q
38 S PSGLDT=$$ENDTC^PSGMI(PSGLDT),PSGLOD=$E($$ENDTC^PSGMI(PSGLOD),1,5)
39 I PSGLSTAT="P"!(PSGLSTAT="U") S PSGLSD=" ",PSGLFD=" ",PSGLST=" "
40 E S PSGLSD=$$ENDTC1^PSGMI(PSGLSD),PSGLSD=$E(PSGLSD,1,5)_$E(PSGLSD,9,14),PSGLFD=$$ENDTC1^PSGMI(PSGLFD)
41 ;I PSGLSTAT="P"!(PSGLSTAT="U") S (PSGLSD,PSGLFD)=" ",PSGLST=" "
42 ;E S PSGLSD=$E($$ENDTC^PSGMI(PSGLSD),1,5),PSGLFD=$$ENDTC^PSGMI(PSGLFD)
43 S:'PSGLRN PSGLRN="_____" I PSGLRN,$D(^VA(200,+PSGLRN,0))#2 S X=^(0),X=$S($P(X,"^",2)]"":$P(X,"^",2),1:$P(X,"^")),PSGLRN=$S(X'[",":X,1:$E(X,$F(X,","))_$E(X))
44 S:'PSGLRPH PSGLRPH="_____" I PSGLRPH,$D(^VA(200,+PSGLRPH,0))#2 S X=^(0),X=$S($P(X,"^",2)]"":$P(X,"^",2),1:$P(X,"^")),PSGLRPH=$S(X'[",":X,1:$E(X,$F(X,","))_$E(X))
45 I $P($G(^PS(51.2,+PSGLMR,0)),"^")]"" S PSGLMR=$E($S($P(^(0),"^",3)]"":$P(^(0),"^",3),1:$P(^(0),"^")),1,5)
46 I $P($G(^VA(200,+PSGLPR,0)),"^")]"" S PSGLPR=$P(^(0),"^")
47 S Q=32-$L(PSGLDO)-$L(PSGLMR) I $L(PSGLSCH)>Q S PSGLSCH=$E(PSGLSCH,1,Q-3)_"..."
48 NEW DRUGNAME
49 D DRGDISP^PSJLMUT1(DFN,$S(PSGORD["A":+PSGORD_"U",PSGORD["U":+PSGORD_"U",1:+PSGORD_"P"),40,34,.DRUGNAME,0)
50 ;* 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=$D(^PSI(58.1,"D",+Y,+PSGLWD))
51 ; naked references below refer to full reference inside indirection @(F_"2)" for either file 53.1 or 55
52 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)
53 I $D(PSGLSTOP) Q
54 ;
55ENP ;
56 ;W $C(13),?1,PSGLOD," | ",PSGLSD," | ",PSGLFD,?35,"(",PSGLBS5,")",?43,"|",PSGLAT(1),?52,PSGLPN,?88,$J($S(PSGLRB]"":PSGLRB,1:"*NF*"),12)
57 I PSGLSD[" ",+$G(@(F_"4)")) S X="P E N D I N G"
58 E S X=PSGLSD_" |"_PSGLFD
59 W $C(13),?1,PSGLOD," |",X,?36,"(",PSGLBS5,")",?42,"|",PSGLAT(1),?52,PSGLPN,?88,$J($S(PSGLRB]"":PSGLRB,1:"*NF*"),12)
60 ;W $C(13),?1,PSGLOD," | ",X,?35,"(",PSGLBS5,")",?43,"|",PSGLAT(1),?52,PSGLPN,?88,$J($S(PSGLRB]"":PSGLRB,1:"*NF*"),12)
61 F X=0:0 S X=$O(DRUGNAME(X)) Q:'X D
62 . I X=1 W !?1,DRUGNAME(X),?42,PSGLST,?43,"|",PSGLAT(2),?52,PSGLSSN,?70,PSGLDOB," (",PSGLAGE,")",?85,$J($S(PSGLTM]"":PSGLTM,1:"NOT FOUND"),15)
63 . I X=2 W !?1,DRUGNAME(X),?43,"|",PSGLAT(3),?52,PSGLSEX,?65,"DX: ",PSGLDX
64 . S L=X+1
65 . I L=5,PSGLSI]"" W "See next label for continuation" D NXTLNE W !,?1
66 . I X>2 W !?1,DRUGNAME(X) D NXTLNE
67 I L=5,PSGLSI]"" W "See next label for continuation" D NXTLNE W !,?1
68 F Y=1:1:$L(PSGLSI," ") S Y1=$P(PSGLSI," ",Y) D
69 .I $L(Y1)>42 F Q:$L(Y1)<42 D
70 ..S LEN=43-$X W $E(Y1,1,LEN) S Y1=$E(Y1,LEN+1,255) D NXTLNE
71 ..I L#5=0 W "See next label for continuation" D NXTLNE W !,?1
72 .I ($X+$L(Y1))>42 D NXTLNE I L#5=0 W "See next label for continuation" D NXTLNE W !,?1
73 .W Y1," "
74 D:PSGLSI]"" NXTLNE
75 I $D(PSGLAT(L+1)) F Q:'$D(PSGLAT(L+1)) D
76 .I L#5=0 W ?1,"See next label for continuation" D NXTLNE W ! Q
77 .D NXTLNE
78 I L#5>0 F Q:L#5=0 D NXTLNE
79 W $E("WS",1,PSGLWS*2) W:PSGLSM ?4,$E("HSM",PSGLSM,3) W ?8,$E("NF",1,PSGLNF*2),?24,"RPH:",PSGLRPH,?33," RN:",PSGLRN D NXTLNE
80 W !
81 Q
82 ;
83NXTLNE ; Print info to right of drug
84 W ?43,"|",$G(PSGLAT(L))
85 I L=4 D
86 .N Y S Y=PSGLR W ?52 W:PSGLDT PSGLDT,?77,$S(Y="NR":"RENEWAL ",Y["N":"NEW ",1:""),"ORDER "
87 .W $S(Y="E":"EDITED",Y="DE":"DC'ED (EDIT)",Y["D":"DISCONTINUED",Y="NE":"(EDIT)",PSGLR="H1":"ON HOLD",PSGLR="H0":"OFF OF HOLD",PSGLR="RE":"REINSTATED",1:"")
88 .I PSGLFFD]"",PSGLFFD'>PSGDT,PSGLR'["D" W " (EXPIRED)"
89 W:L=5 ?52,$S(PSGLWGN]"":$E(PSGLWGN,1,21),1:"NOT FOUND"),?79,$J($S(PSGLWDN]"":$E(PSGLWDN,1,21),1:"NOT FOUND"),21)
90 W !,?1 S L=L+1
91 Q
92ENKV ;*** Kill var created from this routine
93 K PSGDT,PSGLAGE,PSGLAT,PSGLBS5,PSGLDDA,PSGLDO,PSGLDOB,PSGLDRG,PSGLDT,PSGLDX,PSGLFD,PSGLFFD,PSGLMN,PSGLMR,PSGLNF,PSGLOD,PSGLPN
94 K PSGLPR,PSGLR,PSGLRB,PSGLRN,PSGLRPH,PSGLSCH,PSGLSD,PSGLSEX,PSGLSI,PSGLSM,PSGLSSD,PSGLSSN,PSGLST
95 K PSGLSTAT,PSGLSTOP,PSGLTD,PSGLTM,PSGLWD,PSGLWDN,PSGLWGN,PSGLWS,PSGNOW,PSGOP,PSGORD
96 Q
Note: See TracBrowser for help on using the repository browser.