source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOTPRX1.m@ 1119

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

initial load of FOIAVistA 6/30/08 version

File size: 7.4 KB
Line 
1PSOTPRX1 ;BIR/MHA-TPB medication procesing driver ;08/21/03
2 ;;7.0;OUTPATIENT PHARMACY;**146,182,227,268**;DEC 1997;Build 9
3 ;External reference PDA^PPPPDA1 supported by DBIA 1374
4 ;External reference ^PS(55 supported by DBIA 2228
5 ;External reference ^DIC(31 supported by DBIA 658
6 ;External reference EN2^GMRAPEM0 supported by DBIA 190
7 Q ;placed out of order by patch PSO*7*227
8START K PSOQFLG,PSOID,PSOFIN,PSOQUIT,PSODRUG S (PSOBCK,PSOERR)=1 D INIT
9 W:'$D(PSOTPBFG) !!,"*** Transitional Pharmacy Benefit Flag Undefined - Quitting ***"
10 G:PSORX("QFLG")!('$D(PSOTPBFG)) END
11 D PT G:$G(PSORX("QFLG")) END D FULL^VALM1 I $G(NOPROC) K NOPROC G NX
12 ;call to add bingo board data to file 52.11
13 F SLPPL=0:0 S SLPPL=$O(RXRS(SLPPL)) Q:'SLPPL D
14 .I $P($G(^PSRX(SLPPL,"STA")),"^")'=5 K RXRS(SLPPL) Q
15 .S RXREC=SLPPL D WIND^PSOSUPOE I $G(PBINGRTE) D BBADD^PSOSUPOE S (BINGCRT,BINGRTE)=1 S:$G(PSOFROM)'="NEW" PSOFROM="REFILL"
16 K TM,TM1 I $G(PSORX("PSOL",1))]""!($D(RXRS)) D ^PSORXL K PSORX S PSOPBM1=1
17 G:$G(NOBG) NX
18 S TM=$P(^TMP("PSOBB",$J),"^"),TM1=$P(^TMP("PSOBB",$J),"^",2) K ^TMP("PSOBB",$J)
19 I $G(PSOFROM)="NEW"!($G(PSOFROM)="REFILL")!($G(PSOFROM)="PARTIAL") D:$D(BINGCRT)&($D(BINGRTE)&($D(DISGROUP))) ^PSOBING1 K BINGCRT,BINGRTE,BBRX,BBFLG
20 I $G(PSOPBM),$G(PSOPBM1) S $P(^PS(55,PSODFN,0),"^",7)=PSOPBM,$P(^(0),"^",8)="A" K PSOPBM,PSOPBM1
21NX D:$G(PSODFN) EXFLAG^PSOTPCAN(PSODFN) D EOJ G START
22END Q
23 ;---------------------------------------------------------
24INIT ;
25 S PSORX("QFLG")=0
26 D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) S PSORX("QFLG")=1
27 I $P($G(PSOPAR),"^",2),'$D(^XUSEC("PSORPH",DUZ)) S PSORX("VERIFY")=1
28INITX Q
29 ;
30PT ;
31 K ^TMP("PSORXDC",$J),CLOZPAT,DIC,PSODFN,PSOPBM,PSOPBM1 S PSORX("QFLG")=0
32 S DIC("S")="I '$P(^PS(52.91,+Y,0),""^"",3)!($P(^(0),""^"",3)>DT)"
33 S DIC=52.91,DIC(0)="QEAM" D ^DIC K DIC,DA
34 I +Y'>0 S PSORX("QFLG")=1 G PTX
35OERR N:$G(MEDP) PAT,POERR K PSOXFLG S (DFN,PSODFN)=+Y,PSORX("NAME")=$P($G(^DPT(PSODFN,0)),"^")
36 K NPPROC,PSOQFLG,DIC,DR,DIQ S DIC=2,DA=PSODFN,DR=.351,DIQ="PSOPTPST" D EN^DIQ1 K DIC,DA,DR,DIQ D DEAD^PSOPTPST I $G(PSOQFLG) S NOPROC=1 Q
37 I $P($G(^PS(55,PSODFN,"LAN")),"^") W !,"Patient has another language preference!",! H 3
38 D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2) S ^TMP("PSOBB",$J)=TM_"^"_TM1
39 I '$G(MEDP) S X="PPPPDA1" X ^%ZOSF("TEST") S:$T X=$$PDA^PPPPDA1(PSODFN)
40 S PSOQFLG=0,DIC="^PS(55,",DLAYGO=55
41 I $G(PSOFIN) S SSN=$P(^DPT(PSODFN,0),"^",9) W !!?10,$C(7),PSORX("NAME")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_")" K SSN
42 K PSOPBM ; KILL SO THAT WON'T CARRY OVER PRIOR PATIENT'S VALUE
43 I '$D(^PS(55,PSODFN,0)) D
44 .S PSOPBM=$P(TM,".")
45 .K DD,DO S DIC(0)="L",(DINUM,X)=PSODFN D FILE^DICN D:Y<1 K DIC,DA,DR,DD,DO
46 ..S $P(^PS(55,PSODFN,0),"^")=PSODFN K DIK S DA=PSODFN,DIK="^PS(55,",DIK(1)=.01 D EN^DIK K DIK
47 S PSOLOUD=1 D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN) K PSOLOUD
48 I $G(^PS(55,PSODFN,"PS"))']"" D I $G(POERR("QFLG")) G EOJ
49 .L +^PS(55,PSODFN):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W $C(7),!!,"Patient Data is Being Edited by Another User!",! S POERR("QFLG")=1 S:$G(PSOFIN) PSOQUIT=1 Q
50 .S PSOXFLG=1,SSN=$P(^DPT(PSODFN,0),"^",9) W !!?10,$C(7),PSORX("NAME")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_")",! K SSN
51 .S DIE=55,DR=".02;.03;.04;.05;1;D ELIG^PSORX1;@1;3//NON-VA;D CHK^PSOTPRX1;50;106;106.1"
52 .S DA=PSODFN W !!,?5,">>PHARMACY PATIENT DATA<<",! D ^DIE L -^PS(55,PSODFN)
53 .I $D(Y)!($D(DTOUT)) S PSOX=$G(^PS(55,PSODFN,"PS")) D:+$P(PSOX,"^")
54 ..I $$UP^XLFSTR($P(^PS(53,$P(PSOX,"^"),0),"^"))'="NON-VA" S DR="3////@" D ^DIE
55 S PSOX=$G(^PS(55,PSODFN,"PS"))
56 I PSOX]"" S (X,PSORX("PATIENT STATUS"))=$$UP^XLFSTR($P(^PS(53,$P(PSOX,"^"),0),"^")) D:X'="NON-VA" WRN
57 I PSOX']"" D I $G(POERR("QFLG")) G EOJ
58 .W !!,"Patient Status Required!!",! D ELIG
59 .W ! K POERR("QFLG"),DIC,DR,DIE S DIC("B")="NON-VA"
60 .S DIC("A")="PATIENT STATUS: ",DIC(0)="QEAMZ",DIC=53 D ^DIC K DIC
61 .I $D(DIRUT)!(Y=-1) D Q
62 ..W $C(7),"Required Data!",! S POERR("QFLG")=1 S:$G(PSOFIN) PSOQUIT=1
63 ..I $G(PSOPBM) D K PSOPBM
64 ...I $O(^PS(55,PSODFN,0))="" S DA=PSODFN,DIK="^PS(55," D ^DIK
65 .I $$UP^XLFSTR($P(^PS(53,+Y,0),"^"))'="NON-VA" D MES S POERR("QFLG")=1 Q
66 .S ^PS(55,PSODFN,"PS")=+Y,PSORX("PATIENT STATUS")=$P(^PS(53,+Y,0),"^")
67 .D KV
68 Q:$G(PSOFIN)
69PROV ;
70 D ST^PSOTPPRV G:'$G(DA) NX
71 S PSORX("PROVIDER NAME")=$P(^VA(200,DA,0),"^")
72 D KV S DIR("A")="Do you want to enter allergies or adverse reactions at this time?"
73 S DIR("B")="Y",DIR(0)="YN" W !! D ^DIR I Y W !
74 D:Y EN2^GMRAPEM0
75 I '$G(PSOPBM),'$P(^PS(55,PSODFN,0),"^",7),$P(^(0),"^",8)']"" S PSOPBM=$P(TM,".")
76 D ^PSOBUILD
77 F PT="GET","DEAD","INP","CNH","ADDRESS","COPAY" S RTN=PT_"^PSOPTPST" D @RTN Q:$G(POERR("DEAD"))!($G(PSOQFLG))
78 I $G(POERR("DEAD")) S POERR("QFLG")=1 F II=0:0 S II=$O(^PS(52.41,"P",PSODFN,II)) D:$P($G(^PS(52.41,II,0)),"^",3)'="DC"&($P($G(^(0)),"^",3)'="DE") DC^PSOORFI2
79 K PSOERR("DEAD"),II I $G(PSOQFLG) S POERR("QFLG")=1 G EOJ Q
80 S (PAT,PSOXXDFN)=PSODFN,POERR=1 D ^PSOORUT2,BLD^PSOORUT1,EN^PSOLMUTL
81 D CLEAR^VALM1 G:$G(PSOQUIT) PTX D EN^PSOLMAO
82 S (DFN,PSODFN)=PSOXXDFN K DIE,DIC,DLAYGO,DR,DA,PSOX,PSORXED
83PTX ;
84 K X,Y,^TMP("PS",$J),C,DEA,PRC,PSCNT,PSOACT,PSOCLC,PSOCS,PSOCT,PSOFINFL,PSOHD,PSOLST,PSOOPT,PSOPF,PSOX,PSOX1,PSOXXDFN,SIGOK,STP,STR
85 Q
86CHK ;
87 Q:'X
88 I $$UP^XLFSTR($P(^PS(53,+X,0),"^"))'="NON-VA" D MES S Y="@1",$P(^PS(55,PSODFN,"PS"),"^")=""
89 Q
90MES W $C(7),!!,"Invalid Selection - Only 'NON-VA' patient status can be processed through"
91 W !,"this option. For all other statuses use the regular Patient Prescription"
92 W !,"Processing option"
93 Q
94WRN W $C(7),!!?15,"*** Current RX Patient Status is "_X_" ***"
95 W !,"Only 'NON-VA' patient status should be processed through this option."
96 W !,"For all other statuses use the regular Patient Prescription Processing option."
97 Q
98EOJ ;
99 K PSOERR,PSOMED,PSORX,PSOSD,PSODRUG,PSODFN,PSOOPT,PSOBILL,PSOIBQS,PSOCPAY,PSOPF,PSOPI,COMM,DGI,DGS,PT,PTDY,PTRF,RN,RTN,SERS,ST0,STAT,DFN,STOP,SLPPL,RXREC,PSOPBM
100 K:'$G(MEDP) PSOQFLG
101 D KVA^VADPT,FULL^VALM1 K PSOLST,PSOXFLG,PSCNT,PSDIS,PSOAL,P1,LOG,%,%DT,%I,D0,DAT,DFN,DRG,ORX,PSON,PSOPTPST,PTST,PSOBCK,PSOID,PSOBXPUL
102 K INCOM,SIG,SG,STP,RX0,RXN,RX2,RX3,RTS,C,DEAD,PS,PSOCLC,PSOCNT,PSOCT,PSODA,PSOFROM,PSOHD,R3,REA,RF,RFD,RFM,RLD,RXNUM,RXP,RXPR,RXRP,RXRS,STR,POERR,VALMSG
103 K ^TMP("PSORXDC",$J),^TMP("PSOAL",$J),^TMP("PSOAO",$J),^TMP("PSOSF",$J),^TMP("PSOPF",$J),^TMP("PSOPI",$J),^TMP("PSOPO",$J),^TMP("PSOHDR",$J) I '$G(MEDP),'$G(PSOQUIT) K PAT
104 K RFN,PSOXXDFN,VALM,VALMKEY,PSOBCK,SPOERR,PSOFLAG,VALMBCK,D,GMRA,GMRAL,GMRAREC,PSOSTA,PSODT,RXFL,NOBG,BBRX,BBFLG
105KV K DIR,DIRUT,DTOUT,DUOUT,X,Y
106 Q
107ELIG ; shows eligibility and disabilities
108 D ELIG^VADPT W !,"Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):" SC%: "_$P(VAEL(3),"^",2),1:"") S N=0 F S N=$O(VAEL(1,N)) Q:'N W !,?10,$P(VAEL(1,N),"^",2)
109 W !,"Disabilities: " F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I S I1=$S($D(^DPT(DFN,.372,I,0)):^(0),1:"") D:+I1
110 .S PSDIS=$S($P($G(^DIC(31,+I1,0)),"^")]""&($P($G(^(0)),"^",4)']""):$P(^(0),"^"),$P($G(^DIC(31,+I1,0)),"^",4)]"":$P(^(0),"^",4),1:""),PSCNT=$P(I1,"^",2)
111 .W:$L(PSDIS_"-"_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), ")>80 !,?15
112 .W $S($G(PSDIS)]"":PSDIS_"-",1:"")_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), "
113 K N
114 Q
115PROFILE ;
116 S (PSORX("REFILL"),PSORX("RENEW"))=0,PSOX="" D ^PSOBUILD
117 I '$G(PSOSD) W !,"This patient has no prescriptions" S:'$D(DFN) DFN=PSODFN D GMRA^PSODEM G PROFILEX
118 S (PSODRG,PSOX)="" F S PSODRG=$O(PSOSD(PSODRG)) Q:PSODRG="" F S PSOX=$O(PSOSD(PSODRG,PSOX)) Q:PSOX="" S:$P(PSOSD(PSODRG,PSOX),"^",3)="" PSORX("RENEW")=1 S:$P(PSOSD(PSODRG,PSOX),"^",4)="" PSORX("REFILL")=1
119 K PSOX
120PROFILEX ;
121 Q
Note: See TracBrowser for help on using the repository browser.