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

APSQDRG.m

Go to the documentation of this file.
  1. APSQDRG ;IHS/ASDS/JCM/ENM/POC - ORDER ENTRY DRUG SELECTION
  1. ;;6.0;IHS PHARMACY MODIFICATIONS;**3**;FEB 20, 2001
  1. ;;6.0;OUTPATIENT PHARMACY;**40,131**;09/03/97
  1. ;----------------------------------------------------------
  1. START ;
  1. S (PSONEW("DFLG"),PSONEW("FIELD"),PSODRG("QFLG"))=0
  1. D SELECT ; Select Drug
  1. I $G(PSORX("EDIT"))]"",'PSONEW("FIELD") D TRADE
  1. G:PSONEW("DFLG")!(PSODRG("QFLG")) END
  1. D SET ; Set various drug information
  1. ;D POST I PSORX("DFLG") S PSONEW("DFLG")=1 K:'$G(PSORX("EDIT")) PSORX("DFLG") ; Do any post selection action
  1. D POST ;I PSORX("DFLG") S PSONEW("DFLG")=1 K:'$G(PSORX("EDIT")) PSORX("DFLG") ; Do any post selection action DONT WANT TO GET RID OF DELETE FLAG YET IHS/OKCAO/POC
  1. END D EOJ
  1. Q
  1. ;------------------------------------------------------------
  1. ;
  1. SELECT ;
  1. K DIC,X,Y
  1. S DIC="^PSDRUG(",DIC(0)="ZM",X="`"_APSPDIEN
  1. D ^DIC
  1. I Y<0 S STOP=1 Q
  1. K PSOY S PSOY=Y,PSOY(0)=Y(0)
  1. S X="APSQMAN" X ^%ZOSF("TEST") D:$T ^APSQMAN ;IHS/OKCAO/POC 3/30/98
  1. S X="APSQMAN" X ^%ZOSF("TEST") D:'$T ^APSPMAN ;IHS/OKCAO/POC 3/30/98
  1. ;D ^APSPMAN ;IHS/DSD/ENM MANUFACTURER CALL 1-6-95
  1. ;D ^APSQMAN
  1. ;I $P(PSOY(0),"^")="OTHER DRUG"!($P(PSOY(0),"^")="OUTSIDE DRUG") D TRADE ;IHS/OKCAO/POC DELETE THIS FOR NOW
  1. SELECTX K X,Y,DTOUT,DUOUT
  1. Q
  1. ;
  1. TRADE ;
  1. K DIR,DIC,DA,X,Y
  1. S DIR(0)="52,6.5" D ^DIR K DIR,DIC
  1. I $D(DIRUT) S:$D(DUOUT)!$D(DTOUT)&('$D(PSORX("EDIT"))) PSONEW("DFLG")=1 G TRADEX
  1. S PSODRUG("TRADE NAME")=Y
  1. TRADEX K DIRUT,DTOUT,DUOUT,X,Y
  1. Q
  1. ;
  1. SET ;
  1. S PSODRUG("IEN")=+PSOY,PSODRUG("VA CLASS")=$P(PSOY(0),"^",2)
  1. S PSODRUG("NAME")=$P(PSOY(0),"^")
  1. S PSODRUG("NDF")=$S($G(^PSDRUG(+PSOY,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0)
  1. S PSODRUG("MAXDOSE")=$P(PSOY(0),"^",4),PSODRUG("DEA")=$P(PSOY(0),"^",3)
  1. S PSODRUG("CLN")=$S($D(^PSDRUG(+PSOY,"ND")):+$P(^("ND"),"^",6),1:0)
  1. S PSODRUG("SIG")=$P(PSOY(0),"^",5)
  1. S PSODRUG("NDC")=$P($G(^PSDRUG(+PSOY,2)),"^",4)
  1. S PSODRUG("STKLVL")=$G(^PSDRUG(+PSOY,660.1))
  1. G:$G(^PSDRUG(+PSOY,660))']"" SETX
  1. S PSOX1=$G(^PSDRUG(+PSOY,660))
  1. S PSODRUG("COST")=$P($G(PSOX1),"^",6)
  1. S PSODRUG("UNIT")=$P($G(PSOX1),"^",8)
  1. ;S PSODRUG("EXPIRATION DATE")=$P($G(PSOX1),"^",9)
  1. SETX K PSOX1,PSOY
  1. Q
  1. ;
  1. POST ;
  1. S PSORX("DFLG")=0
  1. ;I $G(DUZ("AG"))="I" D ^PSODRG99 ; IHS specific call
  1. D ^PSODRDUP ; Set PSORX("DFLG")=1 if process to stop
  1. ;D ^AZODRDUP ;ADDED FOR OUTSIDE DUPS IHS/OKCAO/POC
  1. S X="APSQDRDU" X ^%ZOSF("TEST") D:$T ^APSQDRDU ;IHS/OKCAO/POC 3/30/98
  1. Q:$G(PSORX("DFLG"))
  1. ;D ^PSODGDGI D:$G(PSORX("INTERVENE"))]"" ^PSORXI G:PSORX("DFLG") POSTX
  1. D ^PSODGDGI G:PSORX("DFLG") POSTX ;IHS/OKCAO/POC 12/3/97 MULTIPLE INTERVENS
  1. ;D ^AZODGDGI G:PSORX("DFLG") POSTX ;ADDED FOR OUTSIDE RXS IHS/OKCAO/POC
  1. S X="APSQDGDG" X ^%ZOSF("TEST") D:$T ^APSQDGDG ;IHS/OKCAO/POC 3/30/98
  1. K PSORX("INTERVENE") ;ADDED TO NOT CAUSE A PROBLEM BELOW IHS/OKCAO/POC
  1. S X="APSQALLE" X ^%ZOSF("TEST") D:$T EN^APSQALLE D:$G(PSORX("INTERVENE"))]"" ^PSORXI G:PSORX("DFLG") POSTX ;ADDED FOR ALLERGY CHECK IHS/OKCAO/POC 11/17/97
  1. D:$P($G(^PSDRUG(PSODRUG("IEN"),"CLOZ1")),"^")]"" CLOZ G:PSORX("DFLG") POSTX
  1. ; Do ^allergy check
  1. ;D ^PSODRDUP ; Set PSORX("DFLG")=1 if process to stop
  1. ; ^Do any other action revolving around the drug selection
  1. POSTX ;
  1. K PSORX("INTERVENE")
  1. Q
  1. ;
  1. EOJ ;
  1. K PSODRG
  1. Q
  1. ;
  1. CLOZ ;
  1. S ANQRTN=$P(^PSDRUG(PSODRUG("IEN"),"CLOZ1"),"^"),ANQX=0
  1. S P(5)=PSODRUG("IEN"),DFN=PSODFN,X=ANQRTN
  1. X ^%ZOSF("TEST") I D @("^"_ANQRTN) S:$G(ANQX) PSORX("DFLG")=1
  1. K P(5),ANQRTN,ANQX,X
  1. Q