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