APSQFUTI ;IHS/DSD/JCM - ASKS DATA FOR RX ORDER ENTRY CONT. [ 05/25/2001 4:06 PM ]
;;6.0;IHS PHARMACY MODIFICATIONS;**1,3**;09/03/97
;;6.0;OUTPATIENT PHARMACY;**34,61,86,73,113**;09/03/97
;THIS ROUTINE IS A COPY OF PSODIR1
;----------------------------------------------------------------
TEST ;FOR UTILITY
;IHS/OKCAO/POC 5/11/2001
N TEST
S TEST=1 ;OK
D ;
.I $S('$D(^PSDRUG(+Y,"I")):0,DT'>^("I"):0,1:1) S TEST=0 W !,"INACTIVE" Q
.I $S($P($G(^PSDRUG(+Y,2)),"^",3)'["O":1,1:0) S TEST=0 W !,"INACTIVE" Q
.;I $P($G(^PSDRUG(+Y,9999999)),U,3)'=+PSOSITE S TEST=0 W !,"MUST BE SAME DIVISION" Q ;PATCH 4
;I '$O(^APSQFAST(DA,2,0)) S TEST2=1
Q:TEST
K X
Q
S APSQTEST=DA
PTSTAT(PSODIR) ;
PTSTATEN K DIC,DR,DIE S PSODIR("FIELD")=0
;S:$G(PSORX("PATIENT STATUS"))]"" DIC("B")=PSORX("PATIENT STATUS")
;S:$G(PSODIR("PATIENT STATUS"))]"" DIC("B")=PSODIR("PATIENT STATUS")
;S DIC("A")="PATIENT STATUS: "
;S DIC(0)="QEAMZ",DIC=53 D ^DIC K DIC
;I X[U,$L(X)>1 D JUMP G PTSTATX
;I $D(DUOUT)!$D(DTOUT) S PSODIR("DFLG")=1 G PTSTATX
;I Y=-1 W *7," Required" G PTSTATEN
;S (PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"))=+Y
S (PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"))=$G(APST) ;IHS/DSD/ENM 01/26/98
;S PSODIR("PTST NODE")=Y(0)
S PSODIR("PTST NODE")=$G(^PS(53,APST,0))
L +^PS(55,PSODFN):0 I '$T G PTSTATX
;S DIE="55",DR="3////"_+Y,DA=PSODFN D ^DIE K DIE,DA,D0
S DIE="55",DR="3////"_APST,DA=PSODFN D ^DIE K DIE,DA,D0
L -^PS(55,PSODFN)
PTSTATX ;K DTOUT,DUOUT,X,Y,DA,APST
K DTOUT,DUOUT,X,Y,DA ;DONT KILL APST IHS/OKCAO/POC 5/26/98
Q
SIG(PSODIR) ;
K DIR,DIC
S DIR(0)="52,10"
S:$G(PSODRUG("SIG"))]"" DIR("B")=PSODRUG("SIG")
S:$G(PSODIR("SIG"))]"" DIR("B")=PSODIR("SIG")
D DIR G:PSODIR("DFLG")!PSODIR("FIELD") SIGX
S PSODIR("SIG")=Y
SIGX K X,Y
Q
QTY(PSODIR) ;
K DIR,DIC
S DIR(0)="52,7" S DIR("A")="QTY ( "_$G(PSODRUG("UNIT"))_" ) "
S:$G(PSODIR("QTY"))]"" DIR("B")=PSODIR("QTY")
D DIR G:PSODIR("DFLG")!PSODIR("FIELD") QTYX
S PSODIR("QTY")=Y
QTYX K X,Y
Q
COPIES(PSODIR) ;
K DIR,DIC
S DIR(0)="52,10.6"
S DIR("B")=$S($G(PSODIR("COPIES"))]"":PSODIR("COPIES"),1:1)
D DIR G:PSODIR("DFLG")!PSODIR("FIELD") COPIESX
S PSODIR("COPIES")=Y
COPIESX K X,Y
Q
;
DAYS(PSODIR) ;
DAYSEN K DIR,DIC
S X="PSORDAY" X ^%ZOSF("TEST") I $T D ^PSORDAY ;IHS/DSD/ENM/POC 05/11/98 DAYS SUPPLY CAL BY POC
S DIR(0)="N^1:180" ;IHS/DSD/ENM 6/8/95
;S DIR(0)="N^1:90"
I $D(PSOZDAY) S DIR("B")=PSOZDAY K PSOZDAY ;IHS/DSD/ENM/POC 05/11/98
E S DIR("B")=$S($G(PSODIR("DAYS SUPPLY"))]"":PSODIR("DAYS SUPPLY"),$P($G(PSODIR("PTST NODE")),"^",3):$P(PSODIR("PTST NODE"),"^",3),1:30) ;IHS/DSD/ENM/POC 05/11/98
S DIR("A")="DAYS SUPPLY",DIR("?")="Enter a whole number between 1 and 180" ;IHS/DSD/ENM 02/06/96 90 REPLACED WITH 180
D DIR G:PSODIR("DFLG")!PSODIR("FIELD") DAYSX
I $G(PSODRUG("MAXDOSE"))]"",$G(PSODIR("QTY"))]"",(+PSODIR("QTY")/Y>PSODRUG("MAXDOSE")) W !,*7," Greater than Maximum dose of ",PSODRUG("MAXDOSE")," per day" G DAYSEN
S PSODIR("DAYS SUPPLY")=Y
DAYSX K X,Y
Q
;
REFILL ;
S APSQFX=X
D ^PSOLSET:'$D(PSOPAR)
;S APSQFDAY=SAVED VALUE IN TEMPLATE OF DAYS SUPPLY
Q:'$D(APSQFDAY)!('$D(APSQFDRU))!('$D(PSOPAR))
S APSQFY=APSQFDRU ;VALUE IN TEMPLATE IE DRUG APSQFDRU
S APSQFY(0)=$G(^PSDRUG(+APSQFY,0))
D SET
S APSQFOUT=$S($O(^PS(53,"B","OUTPATIENT","")):$O(^("")),+$O(^PS(53,"")):$O(^("")),1:0)
S:APSQFOUT APSQFNOU=$G(^PS(53,APSQFOUT,0))
S PSOX1=$S($P($G(APSQFNOU),U,4):$P(APSQFNOU,U,4),1:12) ;MAX # REFILLS
;
K DIR,DIC,PSOX
S PSOX=$S(PSODRUG("DEA")["S":$P(PSOPAR,"^",9),1:12) ;IHS/DSD/ENM 02/06/96 REFILL NBR INCREASED TO 12
S PSOX=$S((PSOX=+$P(PSOPAR,"^",9))&(PSOX1=12)&(PSODRUG("DEA")["S"):PSOX,1:PSOX1) ;IHS/DSD/ENM 02/06/96
S PSOX=$S('PSOX:0,APSQFDAY>120:1,1:PSOX) ;IHS/DSD/ENM 02/06/96
S PSDY=APSQFDAY,PSDY1=$S(PSDY<31:11,PSDY'<31&(PSDY'>60):5,PSDY'<61&(PSDY'>90):3,PSDY'<91&(PSDY'>120):2,PSDY>120:1,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1) S:PSODRUG("DEA")["S" PSOX=$S($P(PSOPAR,"^",9)'="":$P(PSOPAR,"^",9),1:PSOX)
I PSODRUG("DEA")["A",PSODRUG("DEA")'["B" W !,"No refills allowed on Narcotics .." S PSOX=0
I PSOX>5,PSODRUG("DEA")["A",PSODRUG("DEA")["B",PSODRUG("DEA")>2,PSODRUG("DEA")<6 S PSOX=5
W !,"MAXIMUM NUMBER OF REFILLS IS ",PSOX
;K:X>PSOX X
I APSQFX>PSOX K X,APSQFX
E S X=APSQFX
K PSOX,PSOX1,PSDY,PSDY1
K PSODRUG
Q
SET ;
S PSODRUG("IEN")=+APSQFY,PSODRUG("VA CLASS")=$P(APSQFY(0),"^",2)
S PSODRUG("NAME")=$P(APSQFY(0),"^")
S PSODRUG("NDF")=$S($G(^PSDRUG(+APSQFY,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0)
S PSODRUG("MAXDOSE")=$P(APSQFY(0),"^",4),PSODRUG("DEA")=$P(APSQFY(0),"^",3)
S PSODRUG("CLN")=$S($D(^PSDRUG(+APSQFY,"ND")):+$P(^("ND"),"^",6),1:0)
S PSODRUG("SIG")=$P(APSQFY(0),"^",5)
S PSODRUG("NDC")=$P($G(^PSDRUG(+APSQFY,2)),"^",4)
S PSODRUG("STKLVL")=$G(^PSDRUG(+APSQFY,660.1))
G:$G(^PSDRUG(+APSQFY,660))']"" QUIT
S PSOX1=$G(^PSDRUG(+APSQFY,660))
S PSODRUG("COST")=$P($G(PSOX1),"^",6)
S PSODRUG("UNIT")=$P($G(PSOX1),"^",8)
QUIT Q
CM(PSODIR) ;IHS/DSD/ENM CHRONIC MED ENTER/ED 10-05-94
K DIR,DIC
S DIR(0)="52,9999999.02"
S DIR("B")=$S($G(PSODIR("CM"))]"":PSODIR("CM"),1:"N")
D DIR G:PSODIR("DFLG")!PSODIR("FIELD") CMX
S PSODIR("CM")=Y,APSP("CM")=Y ;IHS/DSD/ENM 09/19/96
CMX K X,Y
Q
;
DIR ;
S PSODIR("FIELD")=0
G:$G(DIR(0))']"" DIRX
D ^DIR K DIR,DIE,DIC,DA
I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)),$L($G(X))'>1 S PSODIR("DFLG")=1 G DIRX
I X[U,$L(X)>1 D JUMP
DIRX K DIRUT,DTOUT,DUOUT,DIROUT,PSOX
Q
;
JUMP ;
S X=$P(X,"^",2),DIC="^DD(52,",DIC(0)="QM" D ^DIC K DIC
I Y=-1 S PSODIR("FIELD")=PSODIR("FLD") G JUMPX
I $G(PSONEW1)=0 D JUMP^PSONEW1 G JUMPX
I $G(PSOREF1)=0 D JUMP^PSOREF1 G JUMPX
I $G(PSONEW3)=0 D JUMP^PSONEW3 G JUMPX
I $G(PSORENW3)=0 D JUMP^PSORENW3 G JUMPX
JUMPX S X="^"_X
Q
APSQFUTI ;IHS/DSD/JCM - ASKS DATA FOR RX ORDER ENTRY CONT. [ 05/25/2001 4:06 PM ]
+1 ;;6.0;IHS PHARMACY MODIFICATIONS;**1,3**;09/03/97
+2 ;;6.0;OUTPATIENT PHARMACY;**34,61,86,73,113**;09/03/97
+3 ;THIS ROUTINE IS A COPY OF PSODIR1
+4 ;----------------------------------------------------------------
TEST ;FOR UTILITY
+1 ;IHS/OKCAO/POC 5/11/2001
+2 NEW TEST
+3 ;OK
SET TEST=1
+4 ;
Begin DoDot:1
+5 IF $SELECT('$DATA(^PSDRUG(+Y,"I")):0,DT'>^("I"):0,1:1)
SET TEST=0
WRITE !,"INACTIVE"
QUIT
+6 IF $SELECT($PIECE($GET(^PSDRUG(+Y,2)),"^",3)'["O":1,1:0)
SET TEST=0
WRITE !,"INACTIVE"
QUIT
+7 ;I $P($G(^PSDRUG(+Y,9999999)),U,3)'=+PSOSITE S TEST=0 W !,"MUST BE SAME DIVISION" Q ;PATCH 4
End DoDot:1
+8 ;I '$O(^APSQFAST(DA,2,0)) S TEST2=1
+9 IF TEST
QUIT
+10 KILL X
+11 QUIT
+12 SET APSQTEST=DA
PTSTAT(PSODIR) ;
PTSTATEN KILL DIC,DR,DIE
SET PSODIR("FIELD")=0
+1 ;S:$G(PSORX("PATIENT STATUS"))]"" DIC("B")=PSORX("PATIENT STATUS")
+2 ;S:$G(PSODIR("PATIENT STATUS"))]"" DIC("B")=PSODIR("PATIENT STATUS")
+3 ;S DIC("A")="PATIENT STATUS: "
+4 ;S DIC(0)="QEAMZ",DIC=53 D ^DIC K DIC
+5 ;I X[U,$L(X)>1 D JUMP G PTSTATX
+6 ;I $D(DUOUT)!$D(DTOUT) S PSODIR("DFLG")=1 G PTSTATX
+7 ;I Y=-1 W *7," Required" G PTSTATEN
+8 ;S (PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"))=+Y
+9 ;IHS/DSD/ENM 01/26/98
SET (PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"))=$GET(APST)
+10 ;S PSODIR("PTST NODE")=Y(0)
+11 SET PSODIR("PTST NODE")=$GET(^PS(53,APST,0))
+12 LOCK +^PS(55,PSODFN):0
IF '$TEST
GOTO PTSTATX
+13 ;S DIE="55",DR="3////"_+Y,DA=PSODFN D ^DIE K DIE,DA,D0
+14 SET DIE="55"
SET DR="3////"_APST
SET DA=PSODFN
DO ^DIE
KILL DIE,DA,D0
+15 LOCK -^PS(55,PSODFN)
PTSTATX ;K DTOUT,DUOUT,X,Y,DA,APST
+1 ;DONT KILL APST IHS/OKCAO/POC 5/26/98
KILL DTOUT,DUOUT,X,Y,DA
+2 QUIT
SIG(PSODIR) ;
+1 KILL DIR,DIC
+2 SET DIR(0)="52,10"
+3 IF $GET(PSODRUG("SIG"))]""
SET DIR("B")=PSODRUG("SIG")
+4 IF $GET(PSODIR("SIG"))]""
SET DIR("B")=PSODIR("SIG")
+5 DO DIR
IF PSODIR("DFLG")!PSODIR("FIELD")
GOTO SIGX
+6 SET PSODIR("SIG")=Y
SIGX KILL X,Y
+1 QUIT
QTY(PSODIR) ;
+1 KILL DIR,DIC
+2 SET DIR(0)="52,7"
SET DIR("A")="QTY ( "_$GET(PSODRUG("UNIT"))_" ) "
+3 IF $GET(PSODIR("QTY"))]""
SET DIR("B")=PSODIR("QTY")
+4 DO DIR
IF PSODIR("DFLG")!PSODIR("FIELD")
GOTO QTYX
+5 SET PSODIR("QTY")=Y
QTYX KILL X,Y
+1 QUIT
COPIES(PSODIR) ;
+1 KILL DIR,DIC
+2 SET DIR(0)="52,10.6"
+3 SET DIR("B")=$SELECT($GET(PSODIR("COPIES"))]"":PSODIR("COPIES"),1:1)
+4 DO DIR
IF PSODIR("DFLG")!PSODIR("FIELD")
GOTO COPIESX
+5 SET PSODIR("COPIES")=Y
COPIESX KILL X,Y
+1 QUIT
+2 ;
DAYS(PSODIR) ;
DAYSEN KILL DIR,DIC
+1 ;IHS/DSD/ENM/POC 05/11/98 DAYS SUPPLY CAL BY POC
SET X="PSORDAY"
XECUTE ^%ZOSF("TEST")
IF $TEST
DO ^PSORDAY
+2 ;IHS/DSD/ENM 6/8/95
SET DIR(0)="N^1:180"
+3 ;S DIR(0)="N^1:90"
+4 ;IHS/DSD/ENM/POC 05/11/98
IF $DATA(PSOZDAY)
SET DIR("B")=PSOZDAY
KILL PSOZDAY
+5 ;IHS/DSD/ENM/POC 05/11/98
IF '$TEST
SET DIR("B")=$SELECT($GET(PSODIR("DAYS SUPPLY"))]"":PSODIR("DAYS SUPPLY"),$PIECE($GET(PSODIR("PTST NODE")),"^",3):$PIECE(PSODIR("PTST NODE"),"^",3),1:30)
+6 ;IHS/DSD/ENM 02/06/96 90 REPLACED WITH 180
SET DIR("A")="DAYS SUPPLY"
SET DIR("?")="Enter a whole number between 1 and 180"
+7 DO DIR
IF PSODIR("DFLG")!PSODIR("FIELD")
GOTO DAYSX
+8 IF $GET(PSODRUG("MAXDOSE"))]""
IF $GET(PSODIR("QTY"))]""
IF (+PSODIR("QTY")/Y>PSODRUG("MAXDOSE"))
WRITE !,*7," Greater than Maximum dose of ",PSODRUG("MAXDOSE")," per day"
GOTO DAYSEN
+9 SET PSODIR("DAYS SUPPLY")=Y
DAYSX KILL X,Y
+1 QUIT
+2 ;
REFILL ;
+1 SET APSQFX=X
+2 IF '$DATA(PSOPAR)
DO ^PSOLSET
+3 ;S APSQFDAY=SAVED VALUE IN TEMPLATE OF DAYS SUPPLY
+4 IF '$DATA(APSQFDAY)!('$DATA(APSQFDRU))!('$DATA(PSOPAR))
QUIT
+5 ;VALUE IN TEMPLATE IE DRUG APSQFDRU
SET APSQFY=APSQFDRU
+6 SET APSQFY(0)=$GET(^PSDRUG(+APSQFY,0))
+7 DO SET
+8 SET APSQFOUT=$SELECT($ORDER(^PS(53,"B","OUTPATIENT","")):$ORDER(^("")),+$ORDER(^PS(53,"")):$ORDER(^("")),1:0)
+9 IF APSQFOUT
SET APSQFNOU=$GET(^PS(53,APSQFOUT,0))
+10 ;MAX # REFILLS
SET PSOX1=$SELECT($PIECE($GET(APSQFNOU),U,4):$PIECE(APSQFNOU,U,4),1:12)
+11 ;
+12 KILL DIR,DIC,PSOX
+13 ;IHS/DSD/ENM 02/06/96 REFILL NBR INCREASED TO 12
SET PSOX=$SELECT(PSODRUG("DEA")["S":$PIECE(PSOPAR,"^",9),1:12)
+14 ;IHS/DSD/ENM 02/06/96
SET PSOX=$SELECT((PSOX=+$PIECE(PSOPAR,"^",9))&(PSOX1=12)&(PSODRUG("DEA")["S"):PSOX,1:PSOX1)
+15 ;IHS/DSD/ENM 02/06/96
SET PSOX=$SELECT('PSOX:0,APSQFDAY>120:1,1:PSOX)
+16 SET PSDY=APSQFDAY
SET PSDY1=$SELECT(PSDY<31:11,PSDY'<31&(PSDY'>60):5,PSDY'<61&(PSDY'>90):3,PSDY'<91&(PSDY'>120):2,PSDY>120:1,1:0)
SET PSOX=$SELECT(PSOX'>PSDY1:PSOX,1:PSDY1)
IF PSODRUG("DEA")["S"
SET PSOX=$SELECT($PIECE(PSOPAR,"^",9)'="":$PIECE(PSOPAR,"^",9),1:PSOX)
+17 IF PSODRUG("DEA")["A"
IF PSODRUG("DEA")'["B"
WRITE !,"No refills allowed on Narcotics .."
SET PSOX=0
+18 IF PSOX>5
IF PSODRUG("DEA")["A"
IF PSODRUG("DEA")["B"
IF PSODRUG("DEA")>2
IF PSODRUG("DEA")<6
SET PSOX=5
+19 WRITE !,"MAXIMUM NUMBER OF REFILLS IS ",PSOX
+20 ;K:X>PSOX X
+21 IF APSQFX>PSOX
KILL X,APSQFX
+22 IF '$TEST
SET X=APSQFX
+23 KILL PSOX,PSOX1,PSDY,PSDY1
+24 KILL PSODRUG
+25 QUIT
SET ;
+1 SET PSODRUG("IEN")=+APSQFY
SET PSODRUG("VA CLASS")=$PIECE(APSQFY(0),"^",2)
+2 SET PSODRUG("NAME")=$PIECE(APSQFY(0),"^")
+3 SET PSODRUG("NDF")=$SELECT($GET(^PSDRUG(+APSQFY,"ND"))]"":+^("ND")_"A"_$PIECE(^("ND"),"^",3),1:0)
+4 SET PSODRUG("MAXDOSE")=$PIECE(APSQFY(0),"^",4)
SET PSODRUG("DEA")=$PIECE(APSQFY(0),"^",3)
+5 SET PSODRUG("CLN")=$SELECT($DATA(^PSDRUG(+APSQFY,"ND")):+$PIECE(^("ND"),"^",6),1:0)
+6 SET PSODRUG("SIG")=$PIECE(APSQFY(0),"^",5)
+7 SET PSODRUG("NDC")=$PIECE($GET(^PSDRUG(+APSQFY,2)),"^",4)
+8 SET PSODRUG("STKLVL")=$GET(^PSDRUG(+APSQFY,660.1))
+9 IF $GET(^PSDRUG(+APSQFY,660))']""
GOTO QUIT
+10 SET PSOX1=$GET(^PSDRUG(+APSQFY,660))
+11 SET PSODRUG("COST")=$PIECE($GET(PSOX1),"^",6)
+12 SET PSODRUG("UNIT")=$PIECE($GET(PSOX1),"^",8)
QUIT QUIT
CM(PSODIR) ;IHS/DSD/ENM CHRONIC MED ENTER/ED 10-05-94
+1 KILL DIR,DIC
+2 SET DIR(0)="52,9999999.02"
+3 SET DIR("B")=$SELECT($GET(PSODIR("CM"))]"":PSODIR("CM"),1:"N")
+4 DO DIR
IF PSODIR("DFLG")!PSODIR("FIELD")
GOTO CMX
+5 ;IHS/DSD/ENM 09/19/96
SET PSODIR("CM")=Y
SET APSP("CM")=Y
CMX KILL X,Y
+1 QUIT
+2 ;
DIR ;
+1 SET PSODIR("FIELD")=0
+2 IF $GET(DIR(0))']""
GOTO DIRX
+3 DO ^DIR
KILL DIR,DIE,DIC,DA
+4 IF $DATA(DUOUT)!($DATA(DTOUT))!($DATA(DIROUT))
IF $LENGTH($GET(X))'>1
SET PSODIR("DFLG")=1
GOTO DIRX
+5 IF X[U
IF $LENGTH(X)>1
DO JUMP
DIRX KILL DIRUT,DTOUT,DUOUT,DIROUT,PSOX
+1 QUIT
+2 ;
JUMP ;
+1 SET X=$PIECE(X,"^",2)
SET DIC="^DD(52,"
SET DIC(0)="QM"
DO ^DIC
KILL DIC
+2 IF Y=-1
SET PSODIR("FIELD")=PSODIR("FLD")
GOTO JUMPX
+3 IF $GET(PSONEW1)=0
DO JUMP^PSONEW1
GOTO JUMPX
+4 IF $GET(PSOREF1)=0
DO JUMP^PSOREF1
GOTO JUMPX
+5 IF $GET(PSONEW3)=0
DO JUMP^PSONEW3
GOTO JUMPX
+6 IF $GET(PSORENW3)=0
DO JUMP^PSORENW3
GOTO JUMPX
JUMPX SET X="^"_X
+1 QUIT
