PSJGMRA ;BIR/MV - Retrieve and display Allergy data ;6 Jun 07 3:37 PM
;;5.0;INPATIENT MEDICATIONS;**181,270,260,252,257,281,347**;16 DEC 97;Build 6
;
; Reference to ^PS(50.605 is supported by DBIA 696.
; Reference to ^PSDRUG( is supported by DBIA 2192.
; Reference to ^PSODGAL1 supported by DBIA 5764.
; Reference to ^PS(50.7 supported by DBIA 2180.
; Reference to ^PS(55 supported by DBIA #2191.
;
EN(DFN,PSJDD) ;
;DFN - Patient IEN
;PSJDD - ^PSDRUG IEN
Q:'+$G(DFN)
Q:'+$G(PSJDD)
;N PTR,GMRAING,PSJACK,PSJCLCNT,PSJFLG,PSJVACL,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,PSJNEW,X,Y,PSODRUG,PSODFN,PSJAOC
N DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,X,Y,PSODRUG,PSODFN,PSJAOC
;*347
;K DIC,PSJVACL,^TMP("GMRAOC",$J),^TMP($J,"PSJCLS"),^TMP("PSJDAI",$J)
K DIC,^TMP($J,"PSJCLS"),^TMP("PSJDAI",$J)
S DIC=50,DIC(0)="MQZV",X=PSJDD D ^DIC K DIC Q:Y=-1
S PSODRUG("IEN")=PSJDD,PSODRUG("VA CLASS")=$P(Y(0),"^",2),PSODRUG("NAME")=$P(Y(0),"^")
S:+$G(^PSDRUG(+Y,2)) PSODRUG("OI")=+$G(^(2)),PSODRUG("OIN")=$P(^PS(50.7,+$G(^(2)),0),"^")
S PSODRUG("NDF")=$S($G(^PSDRUG(PSJDD,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0)
;changed in psj*5*260
S PSJAOC=1,PSODFN=DFN D ^PSODGAL1
S:$G(PSGORQF) VALMBCK="R"
;*347
;K ^TMP("GMRAOC",$J),^TMP($J,"PSJCLS")
K ^TMP($J,"PSJCLS")
Q
INTERV(PSJRXREQ,PSJDD1) ;Prompt if user to log an intervention for significant interaction
;PSPRXREQ - intervention type
;PSJDD1 - Prospective drug name
NEW DIR,DTOUT,DIRUT,DIROUT,DUOUT,Y,X
I $G(PSGORQF)=1 Q
S DIR(0)="SA^1:YES;0:NO",DIR("A")="Do you want to Intervene? ",DIR("B")=$S($G(PSJRXREQ)="ALLERGY":"YES",1:"NO")
I $G(PSJDD1)]"" S DIR("A")="Do you want to Intervene with "_PSJDD1_"? "
W ! D ^DIR
S DIR("?",1)="Answer 'YES' if you DO want to enter an intervention for this medication,"
S DIR("?")=" 'NO' if you DON'T want to enter an intervention for this medication,"
I Y S PSGP=DFN D ^PSJRXI W !
Q
RINTERV(PSJRXREQ,PSJDD1) ;Prompt user to log an intervention for critical interaction
;PSPRXREQ - intervention type
;PSJDD1 - Prospective drug name
NEW DIR,DTOUT,DIRUT,DIROUT,DUOUT,Y,X
K PSGORQF
S DIR(0)="SA^1:YES;0:NO",DIR("A")="Do you want to Continue? ",DIR("B")="NO"
I $G(PSJDD1)]"" S DIR("A")="Do you want to Continue with "_PSJDD1_"? "
S DIR("?",1)="Enter 'NO' if you wish to exit without continuing with the order,",DIR("?")="or 'YES' to continue with the order entry process."
D ^DIR
I 'Y S PSGORQF=1 S VALMBCK="R" Q
I Y S PSGP=DFN D ^PSJRXI W !
Q
;
INST(PSJALCO) ;Find Institution for order
N PSJALCR,PSJALCMC,PSJALCCL,PSJALCWA,PSJALCIV,PSJALCIN,PSJALCND,PSJALCP1,PSJALCP2
I PSJALCO="" Q +$$SITE^VASITE(DT)
S PSJALCR=""
;
I PSJALCO["P" D G INSTM
.S PSJALCCL=$P($G(^PS(53.1,+PSJALCO,"DSS")),"^") I PSJALCCL S PSJALCND=$G(^SC(PSJALCCL,0)) D Q
..S PSJALCIN=$P(PSJALCND,"^",4) I PSJALCIN S PSJALCR=PSJALCIN Q
..S PSJALCMC=$P(PSJALCND,"^",15)
.S PSJALCIV=$P($G(^PS(53.1,+PSJALCO,8)),"^",8) I PSJALCIV D Q
..S PSJALCMC=$P($G(^PS(59.5,+PSJALCIV,0)),"^",4) Q
.D INSTW
;
I PSJALCO["U" S PSJALCP1=$P(PSJALCO,"U"),PSJALCP2=$P(PSJALCO,"U",2) D G INSTM
.S PSJALCCL=$P($G(^PS(55,PSJALCP1,5,PSJALCP2,8)),"^") I PSJALCCL S PSJALCND=$G(^SC(PSJALCCL,0)) D Q
..S PSJALCIN=$P(PSJALCND,"^",4) I PSJALCIN S PSJALCR=PSJALCIN Q
..S PSJALCMC=$P(PSJALCND,"^",15)
.D INSTW
;
I PSJALCO["V" S PSJALCP1=$P(PSJALCO,"V"),PSJALCP2=$P(PSJALCO,"V",2) D G INSTM
.S PSJALCCL=$P($G(^PS(55,PSJALCP1,"IV",PSJALCP2,"DSS")),"^") I PSJALCCL S PSJALCND=$G(^SC(PSJALCCL,0)) D Q
..S PSJALCIN=$P(PSJALCND,"^",4) I PSJALCIN S PSJALCR=PSJALCIN Q
..S PSJALCMC=$P(PSJALCND,"^",15)
.S PSJALCIV=$P($G(^PS(55,PSJALCP1,"IV",PSJALCP2,2)),"^",2) I PSJALCIV D Q
..S PSJALCMC=$P($G(^PS(59.5,+PSJALCIV,0)),"^",4) Q
.D INSTW
;
Q +$$SITE^VASITE(DT)
INSTM ;
I PSJALCR Q PSJALCR
I $G(PSJALCMC) Q +$$SITE^VASITE(DT,PSJALCMC)
Q +$$SITE^VASITE(DT)
;
INSTW ;
S PSJALCWA=$$INSTV I PSJALCWA D
.S PSJALCCL=$P($G(^DIC(42,+PSJALCWA,44)),"^") I PSJALCCL D Q:PSJALCR
..S PSJALCND=$G(^SC(PSJALCCL,0)) S PSJALCIN=$P(PSJALCND,"^",4) I PSJALCIN S PSJALCR=PSJALCIN Q
..S PSJALCMC=$P(PSJALCND,"^",15)
.I '$G(PSJALCMC) S PSJALCMC=$P($G(^DIC(42,+PSJALCWA,0)),"^",11)
Q
;
INSTV() ;Retrieve Ward
I '$G(DFN) Q 0
N VAHOW,VAROOT,VAINDT,VAIN,VAERR
D INP^VADPT
Q +$G(VAIN(4))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJGMRA 4357 printed Apr 09, 2024@21:11:06 Page 2
PSJGMRA ;BIR/MV - Retrieve and display Allergy data ;6 Jun 07 3:37 PM
+1 ;;5.0;INPATIENT MEDICATIONS;**181,270,260,252,257,281,347**;16 DEC 97;Build 6
+2 ;
+3 ; Reference to ^PS(50.605 is supported by DBIA 696.
+4 ; Reference to ^PSDRUG( is supported by DBIA 2192.
+5 ; Reference to ^PSODGAL1 supported by DBIA 5764.
+6 ; Reference to ^PS(50.7 supported by DBIA 2180.
+7 ; Reference to ^PS(55 supported by DBIA #2191.
+8 ;
EN(DFN,PSJDD) ;
+1 ;DFN - Patient IEN
+2 ;PSJDD - ^PSDRUG IEN
+3 if '+$GET(DFN)
QUIT
+4 if '+$GET(PSJDD)
QUIT
+5 ;N PTR,GMRAING,PSJACK,PSJCLCNT,PSJFLG,PSJVACL,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,PSJNEW,X,Y,PSODRUG,PSODFN,PSJAOC
+6 NEW DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,X,Y,PSODRUG,PSODFN,PSJAOC
+7 ;*347
+8 ;K DIC,PSJVACL,^TMP("GMRAOC",$J),^TMP($J,"PSJCLS"),^TMP("PSJDAI",$J)
+9 KILL DIC,^TMP($JOB,"PSJCLS"),^TMP("PSJDAI",$JOB)
+10 SET DIC=50
SET DIC(0)="MQZV"
SET X=PSJDD
DO ^DIC
KILL DIC
if Y=-1
QUIT
+11 SET PSODRUG("IEN")=PSJDD
SET PSODRUG("VA CLASS")=$PIECE(Y(0),"^",2)
SET PSODRUG("NAME")=$PIECE(Y(0),"^")
+12 if +$GET(^PSDRUG(+Y,2))
SET PSODRUG("OI")=+$GET(^(2))
SET PSODRUG("OIN")=$PIECE(^PS(50.7,+$GET(^(2)),0),"^")
+13 SET PSODRUG("NDF")=$SELECT($GET(^PSDRUG(PSJDD,"ND"))]"":+^("ND")_"A"_$PIECE(^("ND"),"^",3),1:0)
+14 ;changed in psj*5*260
+15 SET PSJAOC=1
SET PSODFN=DFN
DO ^PSODGAL1
+16 if $GET(PSGORQF)
SET VALMBCK="R"
+17 ;*347
+18 ;K ^TMP("GMRAOC",$J),^TMP($J,"PSJCLS")
+19 KILL ^TMP($JOB,"PSJCLS")
+20 QUIT
INTERV(PSJRXREQ,PSJDD1) ;Prompt if user to log an intervention for significant interaction
+1 ;PSPRXREQ - intervention type
+2 ;PSJDD1 - Prospective drug name
+3 NEW DIR,DTOUT,DIRUT,DIROUT,DUOUT,Y,X
+4 IF $GET(PSGORQF)=1
QUIT
+5 SET DIR(0)="SA^1:YES;0:NO"
SET DIR("A")="Do you want to Intervene? "
SET DIR("B")=$SELECT($GET(PSJRXREQ)="ALLERGY":"YES",1:"NO")
+6 IF $GET(PSJDD1)]""
SET DIR("A")="Do you want to Intervene with "_PSJDD1_"? "
+7 WRITE !
DO ^DIR
+8 SET DIR("?",1)="Answer 'YES' if you DO want to enter an intervention for this medication,"
+9 SET DIR("?")=" 'NO' if you DON'T want to enter an intervention for this medication,"
+10 IF Y
SET PSGP=DFN
DO ^PSJRXI
WRITE !
+11 QUIT
RINTERV(PSJRXREQ,PSJDD1) ;Prompt user to log an intervention for critical interaction
+1 ;PSPRXREQ - intervention type
+2 ;PSJDD1 - Prospective drug name
+3 NEW DIR,DTOUT,DIRUT,DIROUT,DUOUT,Y,X
+4 KILL PSGORQF
+5 SET DIR(0)="SA^1:YES;0:NO"
SET DIR("A")="Do you want to Continue? "
SET DIR("B")="NO"
+6 IF $GET(PSJDD1)]""
SET DIR("A")="Do you want to Continue with "_PSJDD1_"? "
+7 SET DIR("?",1)="Enter 'NO' if you wish to exit without continuing with the order,"
SET DIR("?")="or 'YES' to continue with the order entry process."
+8 DO ^DIR
+9 IF 'Y
SET PSGORQF=1
SET VALMBCK="R"
QUIT
+10 IF Y
SET PSGP=DFN
DO ^PSJRXI
WRITE !
+11 QUIT
+12 ;
INST(PSJALCO) ;Find Institution for order
+1 NEW PSJALCR,PSJALCMC,PSJALCCL,PSJALCWA,PSJALCIV,PSJALCIN,PSJALCND,PSJALCP1,PSJALCP2
+2 IF PSJALCO=""
QUIT +$$SITE^VASITE(DT)
+3 SET PSJALCR=""
+4 ;
+5 IF PSJALCO["P"
Begin DoDot:1
+6 SET PSJALCCL=$PIECE($GET(^PS(53.1,+PSJALCO,"DSS")),"^")
IF PSJALCCL
SET PSJALCND=$GET(^SC(PSJALCCL,0))
Begin DoDot:2
+7 SET PSJALCIN=$PIECE(PSJALCND,"^",4)
IF PSJALCIN
SET PSJALCR=PSJALCIN
QUIT
+8 SET PSJALCMC=$PIECE(PSJALCND,"^",15)
End DoDot:2
QUIT
+9 SET PSJALCIV=$PIECE($GET(^PS(53.1,+PSJALCO,8)),"^",8)
IF PSJALCIV
Begin DoDot:2
+10 SET PSJALCMC=$PIECE($GET(^PS(59.5,+PSJALCIV,0)),"^",4)
QUIT
End DoDot:2
QUIT
+11 DO INSTW
End DoDot:1
GOTO INSTM
+12 ;
+13 IF PSJALCO["U"
SET PSJALCP1=$PIECE(PSJALCO,"U")
SET PSJALCP2=$PIECE(PSJALCO,"U",2)
Begin DoDot:1
+14 SET PSJALCCL=$PIECE($GET(^PS(55,PSJALCP1,5,PSJALCP2,8)),"^")
IF PSJALCCL
SET PSJALCND=$GET(^SC(PSJALCCL,0))
Begin DoDot:2
+15 SET PSJALCIN=$PIECE(PSJALCND,"^",4)
IF PSJALCIN
SET PSJALCR=PSJALCIN
QUIT
+16 SET PSJALCMC=$PIECE(PSJALCND,"^",15)
End DoDot:2
QUIT
+17 DO INSTW
End DoDot:1
GOTO INSTM
+18 ;
+19 IF PSJALCO["V"
SET PSJALCP1=$PIECE(PSJALCO,"V")
SET PSJALCP2=$PIECE(PSJALCO,"V",2)
Begin DoDot:1
+20 SET PSJALCCL=$PIECE($GET(^PS(55,PSJALCP1,"IV",PSJALCP2,"DSS")),"^")
IF PSJALCCL
SET PSJALCND=$GET(^SC(PSJALCCL,0))
Begin DoDot:2
+21 SET PSJALCIN=$PIECE(PSJALCND,"^",4)
IF PSJALCIN
SET PSJALCR=PSJALCIN
QUIT
+22 SET PSJALCMC=$PIECE(PSJALCND,"^",15)
End DoDot:2
QUIT
+23 SET PSJALCIV=$PIECE($GET(^PS(55,PSJALCP1,"IV",PSJALCP2,2)),"^",2)
IF PSJALCIV
Begin DoDot:2
+24 SET PSJALCMC=$PIECE($GET(^PS(59.5,+PSJALCIV,0)),"^",4)
QUIT
End DoDot:2
QUIT
+25 DO INSTW
End DoDot:1
GOTO INSTM
+26 ;
+27 QUIT +$$SITE^VASITE(DT)
INSTM ;
+1 IF PSJALCR
QUIT PSJALCR
+2 IF $GET(PSJALCMC)
QUIT +$$SITE^VASITE(DT,PSJALCMC)
+3 QUIT +$$SITE^VASITE(DT)
+4 ;
INSTW ;
+1 SET PSJALCWA=$$INSTV
IF PSJALCWA
Begin DoDot:1
+2 SET PSJALCCL=$PIECE($GET(^DIC(42,+PSJALCWA,44)),"^")
IF PSJALCCL
Begin DoDot:2
+3 SET PSJALCND=$GET(^SC(PSJALCCL,0))
SET PSJALCIN=$PIECE(PSJALCND,"^",4)
IF PSJALCIN
SET PSJALCR=PSJALCIN
QUIT
+4 SET PSJALCMC=$PIECE(PSJALCND,"^",15)
End DoDot:2
if PSJALCR
QUIT
+5 IF '$GET(PSJALCMC)
SET PSJALCMC=$PIECE($GET(^DIC(42,+PSJALCWA,0)),"^",11)
End DoDot:1
+6 QUIT
+7 ;
INSTV() ;Retrieve Ward
+1 IF '$GET(DFN)
QUIT 0
+2 NEW VAHOW,VAROOT,VAINDT,VAIN,VAERR
+3 DO INP^VADPT
+4 QUIT +$GET(VAIN(4))
