PSOERBT0 ;ALB/MFR - Dispense Drug Conversion Prompts ;Jan 16, 2025@12:43:34
;;7.0;OUTPATIENT PHARMACY;**770**;DEC 16, 1997;Build 145
;
DRUGREP ; VistA Drug Replacement Entry Point
N DIC,DWLW,DWPK,DIWESUB,DUOUT,DIR,CNT,RX,DIRUT,DIROUT,TIUTITLE,PSOTITL,PSODFN,PSOQUIT,STOP,PSOTIUDA,TIUX
S VALMBCK="R" D FULL^VALM1
I $$GET1^DIQ(59.7,1,102,"I")'="MBM" D Q
. S VALMSG="This action is available for Meds-by-Mail (MbM) site only"
D ENTRYSEL^PSOERBT I '$O(^TMP("PSOERSEL",$J,0)) Q
;
; Progress Note for Drug Replacement
W ! K ^TMP("PSOERPN",$J)
S DIC="^TMP(""PSOERPN"""_",$J,"
S DWLW=80,DWPK=1
S DIWESUB="PATIENT PROGRESS NOTE" W !,DIWESUB,":"
W ! D EN^DIWE I $G(DUOUT) Q
;
S (RX,CNT)=0 F S RX=$O(^TMP("PSOERSEL",$J,RX)) Q:'RX S CNT=CNT+1
W ! K DIR S DIR(0)="SA^Y:YES;N:NO",DIR("B")="NO"
S DIR("A")="Are you sure you want to replace the VistA Drug for "
S DIR("A")=DIR("A")_$S(CNT>1:"these "_$G(IOINHI)_CNT_$G(IOINORM)_" Rx's",1:"Rx #"_$$GET1^DIQ(52,+$O(^TMP("PSOERSEL",$J,RX)),.01))_"? "
D ^DIR I $D(DIRUT)!$D(DIROUT)!(Y="N") Q
;
W ! S TIUTITLE="PHARMACY RX DRUG REPLACEMENT"
S PSOTITL=$$FIND1^DIC(8925.1,"","X",TIUTITLE,"B")
S (RXIEN,PSOQUIT)=0
F S RXIEN=$O(^TMP("PSOERSEL",$J,RXIEN)) Q:'RXIEN D I PSOQUIT Q
. ;
. S ENTRYNUM=+$G(^TMP("PSOERSEL",$J,RXIEN))
. W !!,IOINHI_$J(ENTRYNUM,4)_". "_$$GET1^DIQ(52,RXIEN,.01)_" - "_$$GET1^DIQ(52,RXIEN,6)_IOINORM
. W !," Replacing Dispense Drug with "_IOINHI_$$GET1^DIQ(50,NEWDRUG,.01)_IOINORM_"..."
. ;
. S SWAP=$$SWAPDRUG^PSODRGU0(RXIEN,NEWDRUG) W:SWAP IOINHI_"OK"_IOINORM
. I 'SWAP D Q
. . W !,"ERROR: ",$P(SWAP,"^",2)
. . W !! S STOP=$$ASKFLD^PSOSPMA3("E",,"Enter <RET> to continue or '^' to STOP") I STOP="^" S PSOQUIT=1
. ;
. W !," Creating a new Progress Note..."
. K ^TMP("TIUP",$J) M ^TMP("TIUP",$J)=^TMP("PSOERPN",$J)
. S PSODFN=$$GET1^DIQ(52,RXIEN,2,"I")
. D NEW^TIUPNAPI(.PSOTIUDA,PSODFN,DUZ,$$NOW^XLFDT,PSOTITL)
. I +$G(PSOTIUDA)<0 D Q
. . W !,$G(IOINHI),"A problem was encountered while creating the Progress Note.",$G(IOINORM),$C(7),!
. . W !! S STOP=$$ASKFLD^PSOSPMA3("E",,"Enter <RET> to continue or '^' to STOP") I STOP="^" S PSOQUIT=1
. S TIUX(.05)=$$FIND1^DIC(8925.6,"","X","COMPLETED","B")
. S TIUX(1501)=$$NOW^XLFDT()
. S TIUX(1502)=DUZ
. S TIUX(1503)=$$GET1^DIQ(200,+DUZ,20.2)
. S TIUX(1504)=$$GET1^DIQ(200,+DUZ,20.3)
. S TIUX(1505)="E"
. D UPDATE^TIUSRVP(.ERXRET,PSOTIUDA,.TIUX)
. W IOINHI_"OK"_IOINORM
;
I '$G(PSOQUIT) W !!,"Dispense Drug Replacement completed!",!
;
K ^TMP("TIUP",$J),^TMP("PSOERPN",$J) D PAUSE^PSOERXUT
D REF^PSOERBT
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERBT0 2632 printed Sep 23, 2025@20:03:58 Page 2
PSOERBT0 ;ALB/MFR - Dispense Drug Conversion Prompts ;Jan 16, 2025@12:43:34
+1 ;;7.0;OUTPATIENT PHARMACY;**770**;DEC 16, 1997;Build 145
+2 ;
DRUGREP ; VistA Drug Replacement Entry Point
+1 NEW DIC,DWLW,DWPK,DIWESUB,DUOUT,DIR,CNT,RX,DIRUT,DIROUT,TIUTITLE,PSOTITL,PSODFN,PSOQUIT,STOP,PSOTIUDA,TIUX
+2 SET VALMBCK="R"
DO FULL^VALM1
+3 IF $$GET1^DIQ(59.7,1,102,"I")'="MBM"
Begin DoDot:1
+4 SET VALMSG="This action is available for Meds-by-Mail (MbM) site only"
End DoDot:1
QUIT
+5 DO ENTRYSEL^PSOERBT
IF '$ORDER(^TMP("PSOERSEL",$JOB,0))
QUIT
+6 ;
+7 ; Progress Note for Drug Replacement
+8 WRITE !
KILL ^TMP("PSOERPN",$JOB)
+9 SET DIC="^TMP(""PSOERPN"""_",$J,"
+10 SET DWLW=80
SET DWPK=1
+11 SET DIWESUB="PATIENT PROGRESS NOTE"
WRITE !,DIWESUB,":"
+12 WRITE !
DO EN^DIWE
IF $GET(DUOUT)
QUIT
+13 ;
+14 SET (RX,CNT)=0
FOR
SET RX=$ORDER(^TMP("PSOERSEL",$JOB,RX))
if 'RX
QUIT
SET CNT=CNT+1
+15 WRITE !
KILL DIR
SET DIR(0)="SA^Y:YES;N:NO"
SET DIR("B")="NO"
+16 SET DIR("A")="Are you sure you want to replace the VistA Drug for "
+17 SET DIR("A")=DIR("A")_$SELECT(CNT>1:"these "_$GET(IOINHI)_CNT_$GET(IOINORM)_" Rx's",1:"Rx #"_$$GET1^DIQ(52,+$ORDER(^TMP("PSOERSEL",$JOB,RX)),.01))_"? "
+18 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)!(Y="N")
QUIT
+19 ;
+20 WRITE !
SET TIUTITLE="PHARMACY RX DRUG REPLACEMENT"
+21 SET PSOTITL=$$FIND1^DIC(8925.1,"","X",TIUTITLE,"B")
+22 SET (RXIEN,PSOQUIT)=0
+23 FOR
SET RXIEN=$ORDER(^TMP("PSOERSEL",$JOB,RXIEN))
if 'RXIEN
QUIT
Begin DoDot:1
+24 ;
+25 SET ENTRYNUM=+$GET(^TMP("PSOERSEL",$JOB,RXIEN))
+26 WRITE !!,IOINHI_$JUSTIFY(ENTRYNUM,4)_". "_$$GET1^DIQ(52,RXIEN,.01)_" - "_$$GET1^DIQ(52,RXIEN,6)_IOINORM
+27 WRITE !," Replacing Dispense Drug with "_IOINHI_$$GET1^DIQ(50,NEWDRUG,.01)_IOINORM_"..."
+28 ;
+29 SET SWAP=$$SWAPDRUG^PSODRGU0(RXIEN,NEWDRUG)
if SWAP
WRITE IOINHI_"OK"_IOINORM
+30 IF 'SWAP
Begin DoDot:2
+31 WRITE !,"ERROR: ",$PIECE(SWAP,"^",2)
+32 WRITE !!
SET STOP=$$ASKFLD^PSOSPMA3("E",,"Enter <RET> to continue or '^' to STOP")
IF STOP="^"
SET PSOQUIT=1
End DoDot:2
QUIT
+33 ;
+34 WRITE !," Creating a new Progress Note..."
+35 KILL ^TMP("TIUP",$JOB)
MERGE ^TMP("TIUP",$JOB)=^TMP("PSOERPN",$JOB)
+36 SET PSODFN=$$GET1^DIQ(52,RXIEN,2,"I")
+37 DO NEW^TIUPNAPI(.PSOTIUDA,PSODFN,DUZ,$$NOW^XLFDT,PSOTITL)
+38 IF +$GET(PSOTIUDA)<0
Begin DoDot:2
+39 WRITE !,$GET(IOINHI),"A problem was encountered while creating the Progress Note.",$GET(IOINORM),$CHAR(7),!
+40 WRITE !!
SET STOP=$$ASKFLD^PSOSPMA3("E",,"Enter <RET> to continue or '^' to STOP")
IF STOP="^"
SET PSOQUIT=1
End DoDot:2
QUIT
+41 SET TIUX(.05)=$$FIND1^DIC(8925.6,"","X","COMPLETED","B")
+42 SET TIUX(1501)=$$NOW^XLFDT()
+43 SET TIUX(1502)=DUZ
+44 SET TIUX(1503)=$$GET1^DIQ(200,+DUZ,20.2)
+45 SET TIUX(1504)=$$GET1^DIQ(200,+DUZ,20.3)
+46 SET TIUX(1505)="E"
+47 DO UPDATE^TIUSRVP(.ERXRET,PSOTIUDA,.TIUX)
+48 WRITE IOINHI_"OK"_IOINORM
End DoDot:1
IF PSOQUIT
QUIT
+49 ;
+50 IF '$GET(PSOQUIT)
WRITE !!,"Dispense Drug Replacement completed!",!
+51 ;
+52 KILL ^TMP("TIUP",$JOB),^TMP("PSOERPN",$JOB)
DO PAUSE^PSOERXUT
+53 DO REF^PSOERBT
+54 ;
+55 QUIT
