- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR1.m
r613 r623 1 PSODIR1 ;IHS/DSD - ASKS DATA FOR RX ORDER ENTRY CONT. ;6/21/07 8:22am2 ;;7.0;OUTPATIENT PHARMACY;**23,46,78,102,121,131,146,166,184,222,268,206**;DEC 1997;Build 393 4 PTSTAT(PSODIR) 5 PTSTATEN 6 7 8 9 10 11 12 13 14 15 TPBB 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 TPBSC 36 37 38 39 40 PTSTATX 41 42 SIG(PSODIR) 43 44 45 46 47 48 49 50 SIGX 51 52 QTY(PSODIR) 53 QTYA 54 55 56 57 58 59 60 61 62 63 64 65 66 67 QTYX 68 69 COPIES(PSODIR) 70 71 72 73 74 75 COPIESX 76 77 DAYS(PSODIR) 78 DAYSEN 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 DAYSX 100 101 REFILL(PSODIR) 102 103 104 105 106 107 108 109 110 111 I '$D(CLOZPAT) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2) D G REFILLX112 .I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2)!'$O(^PSRX(+$G(PSODIR("IRXN")),1,0))!('$G(PSOLOKED)) D Q113 114 115 116 117 118 119 120 121 122 123 124 125 126 REFILLX 127 128 129 130 REFOR 131 132 133 134 DIR 135 136 137 138 139 140 141 DIRX 142 143 JUMP 144 145 146 147 148 149 150 151 JUMPX 152 153 SIGOK 154 155 156 157 158 159 160 PSTPB 161 162 1 PSODIR1 ;IHS/DSD - ASKS DATA FOR RX ORDER ENTRY CONT. ;02/17/93 17:03 2 ;;7.0;OUTPATIENT PHARMACY;**23,46,78,102,121,131,146,166,184,222,268**;DEC 1997;Build 9 3 ;Ext ref ^PS(55-DBIA 2228, ^PSDRUG(-DBIA 221 4 PTSTAT(PSODIR) ; 5 PTSTATEN K DIC,DR,DIE S PSODIR("FIELD")=0 6 I $G(PSOTPBFG),$G(PSOFROM)="NEW" K PSORX("PATIENT STATUS"),PSODIR("PATIENT STATUS") N PSOFNDRX,PSOFNDFL,PSOFNDPS D 7 .S PSOFNDFL=0 F PSOFNDPS=0:0 S PSOFNDPS=$O(^PS(53,PSOFNDPS)) Q:'PSOFNDPS!(PSOFNDFL) D 8 ..S PSOFNDRX=$P($G(^PS(53,PSOFNDPS,0)),"^") S PSOFNDRX=$$UP^XLFSTR(PSOFNDRX) I PSOFNDRX="NON-VA" S PSOFNDFL=1 S (PSORX("PATIENT STATUS"),DIC("B"))=$P($G(^PS(53,PSOFNDPS,0)),"^") 9 I $G(PSOTPBFG),$G(PSOFROM)="NEW",$G(PSORX("PATIENT STATUS"))="" W !,"Could not find a 'NON-VA' Patient Status in the RX PATIENT STATUS file (#53)!" D PSTPB D S PSODIR("DFLG")=1 G PTSTATX 10 .K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR 11 I $G(PSOTPBFG),$G(PSOFROM)="NEW" G TPBB 12 N PSOX 13 S PSOX=$G(^PS(55,PSODFN,"PS")) I PSOX]"" S PSORX("PATIENT STATUS")=$P($G(^PS(53,PSOX,0)),"^"),DIC("B")=PSORX("PATIENT STATUS") 14 S:$G(PSODIR("PATIENT STATUS"))]"" DIC("B")=PSODIR("PATIENT STATUS") 15 TPBB ; 16 D ELIG^VADPT W !,"Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):" SC%: "_$P(VAEL(3),"^",2),1:"") 17 S N=0 F S N=$O(VAEL(1,N)) Q:'N W !,?10,$P(VAEL(1,N),"^",2) 18 S DIC("A")="RX PATIENT STATUS: " 19 S DIC(0)="QEAMZ",DIC=53 D ^DIC K DIC 20 I $G(PSOTPBFG),$G(PSOFROM)="NEW" N PSOPSDIR,PSOFNDZZ,PSOPSUPA S (PSOPSDIR,PSOPSUPA)=0 D I PSOPSDIR S:PSOPSUPA PSODIR("DFLG")=1 G:PSOPSUPA PTSTATX W ! D PSTPB G PTSTATEN 21 .I +Y'>0!($D(DTOUT))!($D(DUOUT)) S (PSOPSDIR,PSOPSUPA)=1 Q 22 .S (PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"))=+Y,PSODIR("PTST NODE")=Y(0) 23 .S PSOFNDZZ=$P($G(^PS(53,+Y,0)),"^") S PSOFNDZZ=$$UP^XLFSTR(PSOFNDZZ) I PSOFNDZZ'="NON-VA" S PSOPSDIR=1 K PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"),PSODIR("PTST NODE") 24 I $G(PSOTPBFG),$G(PSOFROM)="NEW" G TPBSC 25 I X[U,$L(X)>1 D:'$G(PSOEDIT) JUMP G PTSTATX 26 I $D(DUOUT)!$D(DTOUT) S PSODIR("DFLG")=1 G PTSTATX 27 I Y=-1 W $C(7)," Required" G PTSTATEN 28 N PSOFNDX,PSOFNDXY,PSOFNDXX,PSOFNDYY 29 S PSOFNDXY=$G(Y),PSOFNDYY=$G(Y(0)) 30 I '$G(PSOTPBFG),$G(PSOFROM)="NEW" S PSOFNDX=$P($G(^PS(53,+Y,0)),"^") S PSOFNDXX=$$UP^XLFSTR(PSOFNDX) I PSOFNDXX="NON-VA" K PSOFNDX,PSOFNDXY,PSOFNDYY,PSOFNDXX,Y W !!,"Cannot select 'NON-VA' Rx Patient Status!",! G PTSTATEN 31 S Y=$G(PSOFNDXY),Y(0)=$G(PSOFNDYY) 32 K PSOFNDXY,PSOFNDYY,PSOFNDX,PSOFNDXX 33 S (PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"))=+Y 34 S PSODIR("PTST NODE")=Y(0) 35 TPBSC ; 36 I $G(PSOFDR),$P($G(OR0),"^",17)="C" G PTSTATX 37 L +^PS(55,PSODFN):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T G PTSTATX 38 S DIE="55",DR="3////"_+Y,DA=PSODFN D ^DIE K DIE,DA,D0 39 L -^PS(55,PSODFN) 40 PTSTATX K DTOUT,DUOUT,X,Y,DA 41 Q 42 SIG(PSODIR) ; 43 I $G(PSOFDR),$G(PSODIR("SIG"))']"" D SIGOK G:$G(SIGOK)!($G(PSODIR("DFLG"))) SIGX 44 K DIR,DIC 45 S DIR(0)="52,10" 46 S:$G(PSODRUG("SIG"))]"" DIR("B")=PSODRUG("SIG") 47 S:$G(PSODIR("SIG"))]"" DIR("B")=PSODIR("SIG") 48 D DIR G:PSODIR("DFLG")!PSODIR("FIELD") SIGX 49 S PSODIR("SIG")=Y,SIGOK=0 K SIG 50 SIGX K X,Y 51 Q 52 QTY(PSODIR) ; 53 QTYA K DIR,DIC 54 I $G(CLOZPAT)=1 S DIR("A",1)="Patient Eligible for 14 day supply or 7 day supply with 1 refill" 55 I $G(CLOZPAT)=2 S DIR("A",1)="Patient Eligible 28 day supply or 14 day supply with 1 refill or 7 day supply with 3 refill" 56 S DIR(0)="52,7" S:$G(PSODRUG("IEN")) DIR("A")="QTY ( "_$G(PSODRUG("UNIT"))_" ) "_$S($P($G(^PSDRUG(+PSODRUG("IEN"),5)),"^")]"":$P(^PSDRUG(+PSODRUG("IEN"),5),"^"),1:"") 57 K QTYHLD I $G(PSODIR("QTY"))]"" S QTYHLD=PSODIR("QTY") K PSODIR("QTY") 58 D:'$G(PSOQTY) QTY^PSOSIG(.PSODIR) 59 I '$G(SPEED),$G(QTYHLD),'$G(PSODIR("QTY")) S PSODIR("QTY")=QTYHLD 60 K QTYHLD K:'$G(PSODIR("QTY")) PSODIR("QTY") 61 I $G(SPEED),$G(PSODIR("QTY"))']"" S PSODIR("QTY")=$P(^PSRX(PSORENW("OIRXN"),0),"^",7) 62 S:$G(PSODIR("QTY"))]"" DIR("B")=PSODIR("QTY") 63 D DIR G:PSODIR("DFLG")!PSODIR("FIELD") QTYX 64 I $G(Y),$G(PSODRUG("MAXDOSE"))]"",$G(PSODIR("DAYS SUPPLY")),(Y/+PSODIR("DAYS SUPPLY")>PSODRUG("MAXDOSE")) D G:$G(PSODIR("DFLG")) QTYX G QTYA 65 .W !,$C(7)," Greater than Maximum dose of "_PSODRUG("MAXDOSE")_" per day" D DAYSEN 66 S PSODIR("QTY")=Y 67 QTYX K X,Y 68 Q 69 COPIES(PSODIR) ; 70 K DIR,DIC 71 S DIR(0)="52,10.6" 72 S DIR("B")=$S($G(PSODIR("COPIES"))]"":PSODIR("COPIES"),1:1) 73 D DIR G:PSODIR("DFLG")!PSODIR("FIELD") COPIESX 74 S PSODIR("COPIES")=Y 75 COPIESX K X,Y 76 Q 77 DAYS(PSODIR) ; 78 DAYSEN K DIR,DIC 79 S DIR(0)="N^1:"_$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1:90) 80 S DIR("B")=$S($D(CLOZPAT)&('$G(PSODIR("DAYS SUPPLY"))):7,$G(PSODIR("DAYS SUPPLY"))]"":PSODIR("DAYS SUPPLY"),$P($G(PSODIR("PTST NODE")),"^",3):$P(PSODIR("PTST NODE"),"^",3),1:30) 81 S DIR("A")="DAYS SUPPLY",DIR("?")="Enter a whole number between 1 and "_$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1:90) 82 D DIR G:PSODIR("DFLG")!PSODIR("FIELD") DAYSX 83 I $G(Y),$G(PSODRUG("MAXDOSE"))]"",$G(PSODIR("QTY"))]"",(+PSODIR("QTY")/Y>PSODRUG("MAXDOSE")) W !,$C(7)," Greater than Maximum dose of "_PSODRUG("MAXDOSE")_" per day" G DAYSEN 84 S PSODIR("DAYS SUPPLY")=Y D:$G(PSOFROM)="NEW" 85 .K QTYHLD S:$G(PSODIR("QTY")) QTYHLD=PSODIR("QTY") D QTY^PSOSIG(.PSODIR) 86 .I $G(QTYHLD),'$G(PSODIR("QTY")) S PSODIR("QTY")=QTYHLD 87 .K QTYHLD K:'$G(PSODIR("QTY")) PSODIR("QTY") 88 S:$G(CLOZPAT)=0 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=0 89 D:$G(CLOZPAT)=2 90 .S:PSODIR("DAYS SUPPLY")=28 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=0 91 .S:PSODIR("DAYS SUPPLY")=14 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=1 92 .S:PSODIR("DAYS SUPPLY")=7 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=3 93 D:$G(CLOZPAT)=1 94 .S:PSODIR("DAYS SUPPLY")=14 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=0 95 .S:PSODIR("DAYS SUPPLY")=7 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=1 96 K QTYHLD S:$G(PSODIR("QTY")) QTYHLD=PSODIR("QTY") D QTY^PSOSIG(.PSODIR) 97 I $G(QTYHLD),'$G(PSODIR("QTY")) S PSODIR("QTY")=QTYHLD 98 K QTYHLD K:'$G(PSODIR("QTY")) PSODIR("QTY") 99 DAYSX K X,Y 100 Q 101 REFILL(PSODIR) ; 102 I $G(OR0) G REFOR 103 S PSODIR("CS")=0 K DIR,DIC,PSOX 104 F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSODIR("CS"),"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSODIR("CS"),"^",2)=1 105 I PSODIR("CS") D 106 .S PSOX=5,PSOX1=$S($P($G(PSODIR("PTST NODE")),"^",4)>PSOX:PSOX,1:$P($G(PSODIR("PTST NODE")),"^",4)),PSOX=$S(PSOX1=5:PSOX,1:PSOX1) 107 .S PSOX=$S('PSOX:0,PSODIR("DAYS SUPPLY")=90:1,1:PSOX),PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1) 108 E D 109 .S PSOX=11,PSOX1=$S($P($G(PSODIR("PTST NODE")),"^",4)>PSOX:PSOX,1:$P($G(PSODIR("PTST NODE")),"^",4)),PSOX=$S(PSOX1=11:PSOX,1:PSOX1) 110 .S PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:11,PSDY'<60&(PSDY'>89):5,PSDY=90:3,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1) 111 I '$D(CLOZPAT) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F") D G REFILLX 112 .I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!'$O(^PSRX(+$G(PSODIR("IRXN")),1,0))!('$G(PSOLOKED)) D Q 113 ..S VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["F":"this drug.",1:"Narcotics.") W !,VALMSG,! 114 ..S:$D(PSODIR("FIELD")) PSODIR("FIELD")=0 S PSODIR("# OF REFILLS")=0 115 ..Q 116 .;reset refills to the # given 117 .D RFRSET^PSODIR2 118 .Q 119 I $P($G(PSODIR("CS")),"^",2)=1 W !,"No refills allowed on Schedule 2 drugs...",! S:$D(PSODIR("FIELD")) PSODIR("FIELD")=0 S PSODIR("# OF REFILLS")=0 G REFILLX 120 I $D(CLOZPAT) S PSOX=$S($G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,1:0) 121 S DIR(0)="N^"_$S($G(RFTT):RFTT,1:0)_":"_PSOX,DIR("A")="# OF REFILLS" 122 S DIR("B")=$S($G(COPY):PSODIR("# OF REFILLS"),$G(PSODIR("N# REF"))]"":PSODIR("N# REF"),$G(PSODIR("# OF REFILLS"))]"":PSODIR("# OF REFILLS"),$G(PSOX1)]""&(PSOX>PSOX1):PSOX1,1:PSOX) 123 S DIR("?")="Enter a whole number. The maximum is set by the DAYS SUPPLY field." 124 D DIR G:PSODIR("DFLG")!PSODIR("FIELD") REFILLX 125 S (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=Y 126 REFILLX S:$G(PSODIR("# OF REFILLS"))']"" PSODIR("# OF REFILLS")=$S($G(PSODIR("N# REF"))]"":PSODIR("N# REF"),$G(PSOX1)]""&($G(PSOX)>PSOX1):PSOX1,1:PSOX) 127 K X,Y,PSOX,PSOX1,PSDY,PSDY1,DEA,PSOCS 128 Q 129 ;OERR CALL 130 REFOR ; 131 D REFOR^PSODIR3 132 G REFILLX 133 Q 134 DIR ; 135 S (PSODIR("FIELD"),PSODIR("DFLG"))=0 136 G:$G(DIR(0))']"" DIRX 137 D ^DIR K DIR,DIE,DIC,DA 138 I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)),$L($G(X))'>1!(Y="") S PSODIR("DFLG")=1 G DIRX 139 I $D(DIRUT)!($D(DIROUT)),$G(SPEED) S PSODIR("DFLG")=1 G DIRX 140 I X[U,$L(X)>1 D JUMP 141 DIRX K DIRUT,DTOUT,DUOUT,DIROUT 142 Q 143 JUMP ; 144 I $G(PSOEDIT)!($G(OR0)) S PSODIR("DFLG")=1 Q 145 S X=$P(X,"^",2),DIC="^DD(52,",DIC(0)="QM" D ^DIC K DIC 146 I Y=-1 S PSODIR("FIELD")=PSODIR("FLD") G JUMPX 147 I $G(PSONEW1)=0 D JUMP^PSONEW1 G JUMPX 148 I $G(PSOREF1)=0 D JUMP^PSOREF1 G JUMPX 149 I $G(PSONEW3)=0 D JUMP^PSONEW3 G JUMPX 150 I $G(PSORENW3)=0 D JUMP^PSORENW3 G JUMPX 151 JUMPX S X="^"_X 152 Q 153 SIGOK ;review and decide on oerr sig 154 I '$O(SIG(0)) S SIGOK=0 Q 155 K SIGOK W !,"SIG: " 156 F SIG=0:0 S SIG=$O(SIG(SIG)) W SIG(SIG)_" ",!?5 Q:'$O(SIG(SIG)) 157 K DIR,DIRUT,DUOUT,DTOUT S DIR("B")="YES",DIR(0)="Y",DIR("A")="Is this SIG correct" D ^DIR K DIR I $D(DIRUT) S PSODIR("DFLG")=1 K DIRUT,DUOUT,DTOUT Q 158 S SIGOK=Y I Y K PSODIR("SIG") 159 Q 160 PSTPB ; 161 W !,"New orders entered through this option must have a Patient Status of 'NON-VA'!",! 162 Q
Note:
See TracChangeset
for help on using the changeset viewer.
