source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBLN2.m@ 1261

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

revised back to 6/30/08 version

File size: 5.9 KB
Line 
1PSOLBLN2 ;BHAM ISC/RTR - NEW LABEL TRAILER ; 11/12/06 8:02pm
2 ;;7.0;OUTPATIENT PHARMACY;**92,107,110,208**;DEC 1997;Build 39
3 ; Modified from FOIA VISTA,
4 ; Copyright (C) 2007 WorldVistA
5 ;
6 ; This program is free software; you can redistribute it and/or modify
7 ; it under the terms of the GNU General Public License as published by
8 ; the Free Software Foundation; either version 2 of the License, or
9 ; (at your option) any later version.
10 ;
11 ; This program is distributed in the hope that it will be useful,
12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ; GNU General Public License for more details.
15 ;
16 ; You should have received a copy of the GNU General Public License
17 ; along with this program; if not, write to the Free Software
18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
19 Q:'+$G(RXN)!('$G(PSOTRAIL))!('+$G(DFN))
20 I $G(PSOBLALL),$P(PPL,",",PI+1)'="" Q
21 K ^TMP($J,"PSOMAIL"),^TMP($J,"PSONARR"),^TMP($J,"PSOSUSP") S PRCOPAY=$S('$D(PSOCPN):0,1:1)
22START ;RETURN MAIL
23 S PS=$S($D(^PS(59,PSOSITE,0)):^(0),1:"") I $P(PSOSYS,"^",4),$D(^PS(59,+$P($G(PSOSYS),"^",4),0)) S PS=^PS(59,$P($G(PSOSYS),"^",4),0)
24 S VAADDR1=$P(PS,"^"),VASTREET=$P(PS,"^",2),STATE=$S($D(^DIC(5,+$P(PS,"^",8),0)):$P(^(0),"^",2),1:"UNKNOWN")
25 S PSZIP=$P(PS,"^",5) S PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:""))
26 S ^TMP($J,"PSOMAIL",$S(PRCOPAY:1,1:3))="Pharmacy Service (119)",^($S(PRCOPAY:2,1:4))=$G(VAADDR1),^($S(PRCOPAY:3,1:5))=$G(VASTREET),^($S(PRCOPAY:4,1:6))=$P(PS,"^",7)_", "_$G(STATE)_" "_$G(PSOHZIP)
27 I PRCOPAY F ZZZ=5:1:15 S ^TMP($J,"PSOMAIL",ZZZ)=""
28 I 'PRCOPAY F ZZZ=7:1:17 S ^TMP($J,"PSOMAIL",ZZZ)=""
29 S ^TMP($J,"PSOMAIL",$S(PRCOPAY:16,1:18))="Use the label above to mail the computer",^($S(PRCOPAY:17,1:19))="copies back to us. Apply enough postage",^($S(PRCOPAY:18,1:20))="to your envelope to ensure delivery."
30NARR ;SET TMP GLOBAL FOR NARRATIVES
31 K ^UTILITY($J,"W") S (DIWL,PSNACNT)=1,DIWR=45,DIWF="",(PSSIXFL,PSSEVFL)=0 F ZZ=0:0 S ZZ=$O(^PS(59,PSOSITE,6,ZZ)) Q:'ZZ I $D(^(ZZ,0)) S X=^(0) D ^DIWP
32 F LLL=0:0 S LLL=$O(^UTILITY($J,"W",DIWL,LLL)) Q:'LLL S ^TMP($J,"PSONARR",PSNACNT)=^UTILITY($J,"W",DIWL,LLL,0) S PSNACNT=PSNACNT+1,PSSIXFL=1
33 I PSSIXFL S ^TMP($J,"PSONARR",PSNACNT)="" S PSNACNT=PSNACNT+1
34 S DIWL=1,DIWR=45,DIWF="" K ^UTILITY($J,"W") F ZZ=0:0 S ZZ=$O(^PS(59,PSOSITE,7,ZZ)) Q:'ZZ I $D(^(ZZ,0)) S X=^(0) D ^DIWP
35 F LLL=0:0 S LLL=$O(^UTILITY($J,"W",DIWL,LLL)) Q:'LLL S ^TMP($J,"PSONARR",PSNACNT)=^UTILITY($J,"W",DIWL,LLL,0) S PSNACNT=PSNACNT+1,PSSEVFL=1
36 I $G(PSOCHAMP),$G(PSOTRAMT) D:PSSEVFL S ^TMP($J,"PSONARR",PSNACNT)="REMIT $"_PSOTRAMT_" TO AGENT CASHIER." G SUSP
37 .S ^TMP($J,"PSONARR",PSNACNT)="" S PSNACNT=PSNACNT+1
38 I 'PRCOPAY G SUSP
39 I PSSEVFL S ^TMP($J,"PSONARR",PSNACNT)="" S PSNACNT=PSNACNT+1
40 S DIWL=1,DIWR=45,DIWF="" K ^UTILITY($J,"W") F ZZ=0:0 S ZZ=$O(^PS(59,PSOSITE,4,ZZ)) Q:'ZZ I $D(^(ZZ,0)) S X=^(0) D ^DIWP
41 F LLL=0:0 S LLL=$O(^UTILITY($J,"W",DIWL,LLL)) Q:'LLL S ^TMP($J,"PSONARR",PSNACNT)=^UTILITY($J,"W",DIWL,LLL,0) S PSNACNT=PSNACNT+1
42SUSP ;SUSPENSE DOCUMENT
43 S (PSSUFLG,PSSPCNT)=0 S:'$D(DFN) DFN=+$P($G(^PSRX(RX,0)),"^",2) S PSODFN=DFN,(SPPL,RXX,STA)=""
44 I $G(PSODTCUT)']"" S X1=DT,X2=-120 D C^%DTC S PSODTCUT=X
45 D ^PSOBUILD S (STA,RXX)="" F S STA=$O(PSOSD(STA)) Q:STA="" F S RXX=$O(PSOSD(STA,RXX)) Q:RXX="" I $P(PSOSD(STA,RXX),"^",2)=5 S SPPL=$P(PSOSD(STA,RXX),"^")_","_SPPL
46 D 6^VADPT,PID^VADPT I SPPL="" S PSSUFLG=1 G PRINT
47 S ^TMP($J,"PSOSUSP",1)=$E($P(VADM(2),"^",2),5,12),^(2)=VADM(1),^(3)=$G(VAPA(1)),^(4)=$G(ADDR(2)) I $G(ADDR(3))="",$G(ADDR(4))="" S ^TMP($J,"PSOSUSP",5)="" G ADD
48 I $G(ADDR(3))'="",$G(ADDR(4))="" S ^TMP($J,"PSOSUSP",5)=$G(ADDR(3)) S ^TMP($J,"PSOSUSP",6)="" G ADD
49 S ^TMP($J,"PSOSUSP",5)=$G(ADDR(3)),^(6)=$G(ADDR(4)),^(7)=""
50ADD F ZZ=0:0 S ZZ=$O(^TMP($J,"PSOSUSP",ZZ)) Q:'ZZ S PSSPCNT=ZZ
51 S PSSPCNT=PSSPCNT+1 S ^TMP($J,"PSOSUSP",PSSPCNT)=" The following prescriptions will be" S PSSPCNT=PSSPCNT+1 S ^TMP($J,"PSOSUSP",PSSPCNT)="mailed to you on or after the date indicated." S PSSPCNT=PSSPCNT+1
52 S ^TMP($J,"PSOSUSP",PSSPCNT)="",PSSPCNT=PSSPCNT+1,^(PSSPCNT)="Rx# Date",PSSPCNT=PSSPCNT+1,^(PSSPCNT)="============================================",PSSPCNT=PSSPCNT+1,^(PSSPCNT)="",PSSPCNT=PSSPCNT+1
53 F XX=1:1 Q:$P(SPPL,",",XX)="" S PSSSRX=$P(SPPL,",",XX) D
54 .S SPNUM=$O(^PS(52.5,"B",PSSSRX,0)) I SPNUM S SPDATE=$P($G(^PS(52.5,SPNUM,0)),"^",2) S Y=SPDATE D DD^%DT S SPDATE=Y
55 .S $P(PSOLGTH," ",(20-($L($P(^PSRX(PSSSRX,0),"^")))))="" S ^TMP($J,"PSOSUSP",PSSPCNT)=$P(^PSRX(PSSSRX,0),"^")_PSOLGTH_$G(SPDATE) S PSSPCNT=PSSPCNT+1
56 .S ^TMP($J,"PSOSUSP",PSSPCNT)=" "_$$ZZ^PSOSUTL(PSSSRX) S PSSPCNT=PSSPCNT+1 K SPNUM,SPDATE,Y
57PRINT S PSOTRDFN=$P(VADM(2),"^"),PSOTRDFN=$S(PSOTRDFN]"":PSOTRDFN,1:"Unavailable") S Y=DT X ^DD("DD") S EDT=Y
58 ;W ?54,VADM(1)_" "_$E($P(VADM(2),"^",2),5,12)_" "_EDT ;vfah
59 W ! I PRCOPAY,$G(PSOBARS) S X="S",X2=PSOTRDFN,X1=$X W ?54,@PSOBAR1,PSOTRDFN,@PSOBAR0,$C(13) S $X=0
60 I PRCOPAY,'$G(PSOBARS) W !!!
61 I 'PRCOPAY W !
62 I 'PSSUFLG D PRSUS G END
63 ;S (PSNONARR,PSNOADDR,PSNOBOTH)=0 F TTT=1:1 Q:$G(PSNOBOTH) D ;vfah
64 ;.W $G(^TMP($J,"PSOMAIL",TTT)) S:'$O(^(TTT)) PSNOADDR=1 ;vfah
65 ;.W ?54,$G(^TMP($J,"PSONARR",TTT)),! S:'$O(^(TTT)) PSNONARR=1 ;vfah
66 ;.I PSNOADDR,PSNONARR S PSNOBOTH=1 ;vfah
67END K ^TMP($J,"PSONARR"),^TMP($J,"PSOMAIL"),^TMP($J,"PSOSUSP"),^UTILITY($J,"W")
68 K DIWF,DIWL,DIWR,EDT,LLL,PRCOPAY,PS,PSNACNT,PSNOADDR,PSNOBOTH,PSNONARR,PSNOSUSP,PSNTHREE,PSOLGTH,PSOSD,PSOTRAIL,PSOTRDFN,PSSEVFL,PSSIXFL,PSSPCNT,PSSSRX,PSSUFLG,RXX,SPDATE,SPNUM,SPPL,STATE,TTT,VAADDR1,VADM,VAEL,VAPA,VASTREET,ZZ,ZZZ W @IOF
69 ;I $P(PSOPAR,"^",31) D BLANK^PSOLBLD W @IOF
70 I $P(PSOPAR,"^",31)="1" D BLANK^PSOLBLD W @IOF ;vfah
71 Q
72PRSUS S (PSNONARR,PSNOADDR,PSNOSUSP,PSNTHREE)=0 F TTT=1:1 Q:$G(PSNTHREE) D
73 .W $G(^TMP($J,"PSOMAIL",TTT)) S:'$O(^(TTT)) PSNOADDR=1
74 .W ?54,$G(^TMP($J,"PSONARR",TTT)) S:'$O(^(TTT)) PSNONARR=1
75 .W ?102,$G(^TMP($J,"PSOSUSP",TTT)),! S:'$O(^(TTT)) PSNOSUSP=1
76 .I PSNOADDR,PSNONARR,PSNOSUSP S PSNTHREE=1
Note: See TracBrowser for help on using the repository browser.