Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APSQFUTI

APSQFUTI.m

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