- 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 Jan 18, 2025@03:10:16 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