PSJRXI ; IHS/DSD,JCM,RLW - LOGS PHARMACY INTERVENTIONS ;15 May 98 9:28 AM
;;5.0;INPATIENT MEDICATIONS;**3,181,254,267,275,281**;16 DEC 97;Build 113
;
;Reference to ^APSPQA(32.4 is supported by DBIA #2179
;Reference to ^PSDRUG( supported by DBIA #2192
;Reference to ^DD("DILOCKTM" supported by DBIA #999
;
; This routine is used to create entries in the APSP INTERVENTION file.
;---------------------------------------------------------------
START ;
N SAVEX,SAVEY S SAVEX=X,SAVEY=Y
D INIT
D DIC G:PSJRXI("QFLG") END
D EDIT
S:'$D(PSJNEW("PROVIDER")) PSJNEW("PROVIDER")=$P(^APSPQA(32.4,PSJRXI("DA"),0),"^",3)
END D EOJ
Q
;---------------------------------------------------------------
INIT ;
W !!,"Now creating Pharmacy Intervention",!
I $G(PSJDD) W "For ",$P($G(^PSDRUG(PSJDD,0)),"^"),!
K PSJRXI
S PSJRXI("QFLG")=0
Q
;
DIC ;
N DIC,DR,DA,X,DD,DO,Y,PSJY,PSJRXIEN
I $G(PSJRXREQ)="" S PSJRXREQ="ALLERGY"
D FIND^DIC(9009032.3,"","@;.01","",PSJRXREQ,1,"B","","","PSJRXIEN")
S PSJRXIEN=$G(PSJRXIEN("DILIST",2,1))
I 'PSJRXIEN S PSJY=-1 G DICX
S DIC="^APSPQA(32.4,",DLAYGO=9009032.4,DIC(0)="L",X=DT
S DIC("DR")=".02////"_PSGP_";.04////"_DUZ_";.05////"_PSJDD_";.06///PHARMACY"
S DIC("DR")=DIC("DR")_";.07////"_$G(PSJRXIEN)_";.14////1"_";.16////"_$S($G(PSJSITE)]"":PSJSITE,1:"")
D FILE^DICN K DIC,DR,DA
S PSJY=Y
I Y>0 S PSJRXI("DA")=+Y
E S PSJRXI("QFLG")=1 G DICX
D DIE
DICX ;
I $G(PSJY)=-1 D
. W !!,"Unable to log an intervention for ",$G(PSJRXREQ)
. D PAUSE^PSJLMUT1
K X,Y
Q
DIE ;
K DIE,DIC,DR,DA N PSJRECOM,PSJOVRS,PSJINTOI,PSJTMPDT
S DIE="^APSPQA(32.4,",DA=PSJRXI("DA"),DR=$S($G(PSJRXI("EDIT"))]"":".03:1600",$G(PSJAADPT):".03;",1:".03;.08")
L +^APSPQA(32.4,PSJRXI("DA")):$S($G(^DD("DILOCKTM")):+$G(^DD("DILOCKTM")),1:3) E W !,"Sorry, someone else is editing this intervention!" Q
D ^DIE K DIE,DIC,DR,X,Y,DA
I $G(PSJAADPT) N PSJQREC S PSJQREC=0 F Q:$G(PSJQREC) D
.K DIC S PSJQREC="" S DIC="9009032.5",DIC(0)="EZ",X="UNABLE TO ASSESS" D ^DIC S:$G(Y)>0 PSJQREC=+Y I '($G(Y)>0) S DIC="9009032.5",DIC(0)="EZ",X="OTHER" D ^DIC S:$G(Y)>0 PSJQREC=+Y
.N DIR S DIR(0)="S^1:UNABLE TO ASSESS;2:OTHER",DIR("A")="RECOMMENDATION",DIR("?",1)=" Enter a recommendation for NO ALLERGY ASSESSMENT.",DIR("?")=" Enter 'OTHER' to add free text."
.D ^DIR S PSJQREC=$S(PSJQREC>0:+PSJQREC,1:0) I PSJQREC D
..S DIE="^APSPQA(32.4,",DA=PSJRXI("DA"),DR=".08////"_PSJQREC D ^DIE
.I $G(Y)="^" S PSJQREC=-1
.K DIE,DIC,DR,X,Y,DA
I $G(PSJDD) S PSJINTOI=+$G(^PSDRUG(+PSJDD,2))
S PSJTMPDT=+$G(^TMP("PSJINTER",$J,+$G(PSJRXI("DA"))-1))
I $G(PSGDT) I $G(PSJRXREQ)="ALLERGY"!($G(PSJRXREQ)["CRITICAL DRUG") S ^TMP("PSJINTER",$J,PSJRXI("DA"))=$S($G(PSJTMPDT):PSJTMPDT,1:$G(PSGDT))_"^"_$S($G(PSJINTOI):PSJINTOI,1:"")_"^"_$$DATE2^PSJUTL2($$DATE^PSJUTL2())
S PSJRECOM=$P($G(^APSPQA(32.4,PSJRXI("DA"),0)),"^",8) D
.S PSJOVRS="",X=PSJRECOM,Y="",DIC="^APSPQA(32.5,",DIC(0)="BSX" D ^DIC I $P(Y,"^",2)]"" S PSJOVRS=$P(Y,"^",2)
.I PSJRECOM=9 D
..S DIE="^APSPQA(32.4,",DA=PSJRXI("DA"),DR="1200;" D ^DIE K DIE,DIC,DR,X,Y,DA
L -^APSPQA(32.4,PSJRXI("DA"))
W $C(7),!!,"See 'Pharmacy Intervention Menu' if you want to delete this",!,"intervention or for more options.",! D PAUSE^PSJLMUT1
Q
EDIT ;
K DIR W ! S DIR(0)="Y",DIR("A")="Would you like to edit this intervention",DIR("B")="N" D ^DIR K DIR I $D(DIRUT)!'Y G EDITX
S PSJRXI("EDIT")=1 D DIE
G EDIT
EDITX K X,Y
Q
;
EOJ ;
I $G(PSJDAL) S PSJDAL("DA")=$G(PSJRXI("DA"))
K PSJRXI S X=SAVEX,Y=SAVEY
Q
;
EN1(PSJORDER) ; Entry Point if have internal rx #
I PSJX']"" W !,$C(7),"No prescription data" Q
S PSJORDER=$S((PSJORDER["N")!(PSJORDER["P"):"^PS(53.1,"_+PSJORDER,PSJORDER["V":"^PS(55,"_DFN_",""IV"","_+PSJORDER,1:"^PS(55,"_DFN_",5,"_+PSJORDER)_","
N PSJDFN,PSJNEW,PSJDRUG,PSJY
I $G(^PS(53.1,PSJX,0))']"" W !,$C(7),"No prescription data" G EN1X
S PSJRXI("IRXN")=PSJORDER
K PSJY S PSJY=@(PSJORDER_",0)")
S PSJDFN=$P(PSJY,"^",15),PSJNEW("PROVIDER")=$P(PSJY,"^",2)
S PSJDRUG=0,PSJDRUG=$O(^PS(53.1,PSJRXI("IRXN"),1,PSJDRUG)) Q:'PSJDRUG S PSJDRUG("IEN")=$G(@(PSJORDER_","_PSJDRUG),"^")
D START
EN1X Q
;
EN3(PSJIVDST,CDRG2) ; Entry Point for Clinical Reminders
;PSJIVDST = intervention text
N PSJIVDSN S PSJIVDSN=0
;D LOOK I 'PSJIVDSN Q 1
S PSJRXREQ=PSJIVDST
S PSJDD=CDRG2
D START K PSJIVDSN,CDRG2
EN3X Q 0
;
LOOK ;Find Internal Number of 32.3 file
S PSJRXIEN=$$FIND1^DIC(9009032.3,"","X",PSJIVDST,"B")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJRXI 4488 printed Apr 09, 2024@21:05:41 Page 2
PSJRXI ; IHS/DSD,JCM,RLW - LOGS PHARMACY INTERVENTIONS ;15 May 98 9:28 AM
+1 ;;5.0;INPATIENT MEDICATIONS;**3,181,254,267,275,281**;16 DEC 97;Build 113
+2 ;
+3 ;Reference to ^APSPQA(32.4 is supported by DBIA #2179
+4 ;Reference to ^PSDRUG( supported by DBIA #2192
+5 ;Reference to ^DD("DILOCKTM" supported by DBIA #999
+6 ;
+7 ; This routine is used to create entries in the APSP INTERVENTION file.
+8 ;---------------------------------------------------------------
START ;
+1 NEW SAVEX,SAVEY
SET SAVEX=X
SET SAVEY=Y
+2 DO INIT
+3 DO DIC
if PSJRXI("QFLG")
GOTO END
+4 DO EDIT
+5 if '$DATA(PSJNEW("PROVIDER"))
SET PSJNEW("PROVIDER")=$PIECE(^APSPQA(32.4,PSJRXI("DA"),0),"^",3)
END DO EOJ
+1 QUIT
+2 ;---------------------------------------------------------------
INIT ;
+1 WRITE !!,"Now creating Pharmacy Intervention",!
+2 IF $GET(PSJDD)
WRITE "For ",$PIECE($GET(^PSDRUG(PSJDD,0)),"^"),!
+3 KILL PSJRXI
+4 SET PSJRXI("QFLG")=0
+5 QUIT
+6 ;
DIC ;
+1 NEW DIC,DR,DA,X,DD,DO,Y,PSJY,PSJRXIEN
+2 IF $GET(PSJRXREQ)=""
SET PSJRXREQ="ALLERGY"
+3 DO FIND^DIC(9009032.3,"","@;.01","",PSJRXREQ,1,"B","","","PSJRXIEN")
+4 SET PSJRXIEN=$GET(PSJRXIEN("DILIST",2,1))
+5 IF 'PSJRXIEN
SET PSJY=-1
GOTO DICX
+6 SET DIC="^APSPQA(32.4,"
SET DLAYGO=9009032.4
SET DIC(0)="L"
SET X=DT
+7 SET DIC("DR")=".02////"_PSGP_";.04////"_DUZ_";.05////"_PSJDD_";.06///PHARMACY"
+8 SET DIC("DR")=DIC("DR")_";.07////"_$GET(PSJRXIEN)_";.14////1"_";.16////"_$SELECT($GET(PSJSITE)]"":PSJSITE,1:"")
+9 DO FILE^DICN
KILL DIC,DR,DA
+10 SET PSJY=Y
+11 IF Y>0
SET PSJRXI("DA")=+Y
+12 IF '$TEST
SET PSJRXI("QFLG")=1
GOTO DICX
+13 DO DIE
DICX ;
+1 IF $GET(PSJY)=-1
Begin DoDot:1
+2 WRITE !!,"Unable to log an intervention for ",$GET(PSJRXREQ)
+3 DO PAUSE^PSJLMUT1
End DoDot:1
+4 KILL X,Y
+5 QUIT
DIE ;
+1 KILL DIE,DIC,DR,DA
NEW PSJRECOM,PSJOVRS,PSJINTOI,PSJTMPDT
+2 SET DIE="^APSPQA(32.4,"
SET DA=PSJRXI("DA")
SET DR=$SELECT($GET(PSJRXI("EDIT"))]"":".03:1600",$GET(PSJAADPT):".03;",1:".03;.08")
+3 LOCK +^APSPQA(32.4,PSJRXI("DA")):$SELECT($GET(^DD("DILOCKTM")):+$GET(^DD("DILOCKTM")),1:3)
IF '$TEST
WRITE !,"Sorry, someone else is editing this intervention!"
QUIT
+4 DO ^DIE
KILL DIE,DIC,DR,X,Y,DA
+5 IF $GET(PSJAADPT)
NEW PSJQREC
SET PSJQREC=0
FOR
if $GET(PSJQREC)
QUIT
Begin DoDot:1
+6 KILL DIC
SET PSJQREC=""
SET DIC="9009032.5"
SET DIC(0)="EZ"
SET X="UNABLE TO ASSESS"
DO ^DIC
if $GET(Y)>0
SET PSJQREC=+Y
IF '($GET(Y)>0)
SET DIC="9009032.5"
SET DIC(0)="EZ"
SET X="OTHER"
DO ^DIC
if $GET(Y)>0
SET PSJQREC=+Y
+7 NEW DIR
SET DIR(0)="S^1:UNABLE TO ASSESS;2:OTHER"
SET DIR("A")="RECOMMENDATION"
SET DIR("?",1)=" Enter a recommendation for NO ALLERGY ASSESSMENT."
SET DIR("?")=" Enter 'OTHER' to add free text."
+8 DO ^DIR
SET PSJQREC=$SELECT(PSJQREC>0:+PSJQREC,1:0)
IF PSJQREC
Begin DoDot:2
+9 SET DIE="^APSPQA(32.4,"
SET DA=PSJRXI("DA")
SET DR=".08////"_PSJQREC
DO ^DIE
End DoDot:2
+10 IF $GET(Y)="^"
SET PSJQREC=-1
+11 KILL DIE,DIC,DR,X,Y,DA
End DoDot:1
+12 IF $GET(PSJDD)
SET PSJINTOI=+$GET(^PSDRUG(+PSJDD,2))
+13 SET PSJTMPDT=+$GET(^TMP("PSJINTER",$JOB,+$GET(PSJRXI("DA"))-1))
+14 IF $GET(PSGDT)
IF $GET(PSJRXREQ)="ALLERGY"!($GET(PSJRXREQ)["CRITICAL DRUG")
SET ^TMP("PSJINTER",$JOB,PSJRXI("DA"))=$SELECT($GET(PSJTMPDT):PSJTMPDT,1:$GET(PSGDT))_"^"_$SELECT($GET(PSJINTOI):PSJINTOI,1:"")_"^"_$$DATE2^PSJUTL2($$DATE^PSJUTL2())
+15 SET PSJRECOM=$PIECE($GET(^APSPQA(32.4,PSJRXI("DA"),0)),"^",8)
Begin DoDot:1
+16 SET PSJOVRS=""
SET X=PSJRECOM
SET Y=""
SET DIC="^APSPQA(32.5,"
SET DIC(0)="BSX"
DO ^DIC
IF $PIECE(Y,"^",2)]""
SET PSJOVRS=$PIECE(Y,"^",2)
+17 IF PSJRECOM=9
Begin DoDot:2
+18 SET DIE="^APSPQA(32.4,"
SET DA=PSJRXI("DA")
SET DR="1200;"
DO ^DIE
KILL DIE,DIC,DR,X,Y,DA
End DoDot:2
End DoDot:1
+19 LOCK -^APSPQA(32.4,PSJRXI("DA"))
+20 WRITE $CHAR(7),!!,"See 'Pharmacy Intervention Menu' if you want to delete this",!,"intervention or for more options.",!
DO PAUSE^PSJLMUT1
+21 QUIT
EDIT ;
+1 KILL DIR
WRITE !
SET DIR(0)="Y"
SET DIR("A")="Would you like to edit this intervention"
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)!'Y
GOTO EDITX
+2 SET PSJRXI("EDIT")=1
DO DIE
+3 GOTO EDIT
EDITX KILL X,Y
+1 QUIT
+2 ;
EOJ ;
+1 IF $GET(PSJDAL)
SET PSJDAL("DA")=$GET(PSJRXI("DA"))
+2 KILL PSJRXI
SET X=SAVEX
SET Y=SAVEY
+3 QUIT
+4 ;
EN1(PSJORDER) ; Entry Point if have internal rx #
+1 IF PSJX']""
WRITE !,$CHAR(7),"No prescription data"
QUIT
+2 SET PSJORDER=$SELECT((PSJORDER["N")!(PSJORDER["P"):"^PS(53.1,"_+PSJORDER,PSJORDER["V":"^PS(55,"_DFN_",""IV"","_+PSJORDER,1:"^PS(55,"_DFN_",5,"_+PSJORDER)_","
+3 NEW PSJDFN,PSJNEW,PSJDRUG,PSJY
+4 IF $GET(^PS(53.1,PSJX,0))']""
WRITE !,$CHAR(7),"No prescription data"
GOTO EN1X
+5 SET PSJRXI("IRXN")=PSJORDER
+6 KILL PSJY
SET PSJY=@(PSJORDER_",0)")
+7 SET PSJDFN=$PIECE(PSJY,"^",15)
SET PSJNEW("PROVIDER")=$PIECE(PSJY,"^",2)
+8 SET PSJDRUG=0
SET PSJDRUG=$ORDER(^PS(53.1,PSJRXI("IRXN"),1,PSJDRUG))
if 'PSJDRUG
QUIT
SET PSJDRUG("IEN")=$GET(@(PSJORDER_","_PSJDRUG),"^")
+9 DO START
EN1X QUIT
+1 ;
EN3(PSJIVDST,CDRG2) ; Entry Point for Clinical Reminders
+1 ;PSJIVDST = intervention text
+2 NEW PSJIVDSN
SET PSJIVDSN=0
+3 ;D LOOK I 'PSJIVDSN Q 1
+4 SET PSJRXREQ=PSJIVDST
+5 SET PSJDD=CDRG2
+6 DO START
KILL PSJIVDSN,CDRG2
EN3X QUIT 0
+1 ;
LOOK ;Find Internal Number of 32.3 file
+1 SET PSJRXIEN=$$FIND1^DIC(9009032.3,"","X",PSJIVDST,"B")
+2 QUIT
