APSPORXE ;IHS/TUCSON/LAB - enter outside rx [ 02/20/2001 1:51 PM ];09-Oct-2008 11:25;SM
;;7.0;IHS PHARMACY MODIFICATIONS;**1,2,3,1007**;Sep 23, 2004
;
; Modified - IHS/MSC/PLS - 05/19/08 - Line FIND+1
;
START ;EP - called from option
HDR ;write header
W:$D(IOF) @IOF
F J=1:1:7 S X=$P($T(TEXT+J),";;",2) W !?80-$L(X)\2,X
K X,J
W !!
;IHS/DSD/ENM/POC 05/11/98 NEXT THREE LINES
S X="IOBON;IOBOFF" D ENDR^%ZISS
S X="WARNING! NO DRUG INTERACTIONS OR CLASS CHECKING DONE IN THIS MODE"
W ?80-$L(X)\2,IOBON,X,IOBOFF
;
BEGIN ;
I $G(APSPTYPE)="" W !!,$C(7),$C(7),"TYPE OF ACTION MISSING" H 2 G EXIT
I "ED"'[$G(APSPTYPE) W !!,$C(7),$C(7),"TYPE OF ACTION MISSING" H 2 G EXIT
D INIT^APSPORXA
G:APSPQUIT EXIT
D GETPAT^APSPORXA
G:DFN="" EXIT
D GETDATE^APSPORXA
G:APSPDATE="" EXIT
D @APSPTYPE
D EXIT
Q
EXIT ;cleanup and exit
K APSPOIEN,APSPDRUG,APSPDIEN,APSPOL,APSPDATE,APSPQUIT,APSPSEL,APSPX,APSPRX,APSPC,APSPER,APSPHIGH,APSPTYPE,APSPY ;IHS/DSD/ENM 12/26/95 APSPDOL REMOVED
K M,P,V,X,Y,A,B,C,D,DIE,DIC,DIR,DTOUT,DUOUT,DIRUT,DA,DR,DIV,DIW,DIY,DIQ,DD,D0,DI,DQ,%DT,APCDVDLT,APCDVLDT
D KILL^AUPNPAT K DFN,APCDPAT
Q
FIND ;find all rx's on that date
;IHS/MSC/PLS - 05/19/08 - Updated call to PCC
;K APSPRX S Y="APSPRX(",X=DFN_"^ALL MEDS;DURING "_APSPDATE_"-"_APSPDATE S APSPER=$$^APCLDF(X,Y)
K APSPRX S Y="APSPRX(",X=DFN_"^ALL MEDS;DURING "_APSPDATE_"-"_APSPDATE S APSPER=$$START1^APCLDF(X,Y)
I APSPER W !!,"ERROR in finding outside rx's - data fetcher error!!" K APSPRX Q
S X=0 F S X=$O(APSPRX(X)) Q:X'=+X S V=$P(APSPRX(X),U,5),M=+$P(APSPRX(X),U,4) I $P(^AUPNVSIT(V,0),U,7)'="E" K APSPRX(X)
I '$D(APSPRX) W !!,$C(7),$C(7),"No OUTSIDE Rx's recorded for ",$P(^DPT(DFN,0),U)," on " S Y=APSPDATE D DD^%DT W Y,".",! Q
Q
E ;
D FIND
Q:'$D(APSPRX)
S (X,C)=0 K APSPC F S X=$O(APSPRX(X)) Q:X'=+X S C=C+1,APSPC(C)=X
D DISP
S DIR(0)="NO^1:"_APSPHIGH,DIR("A")="Edit which of the above" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q:$D(DIRUT)
Q:Y=""
S APSPSEL=+Y,APSPX=APSPC(APSPSEL),DA=+$P(APSPRX(APSPX),U,5),DIE="^AUPNVSIT(",DR=2101 D ^DIE K DIE,DR,DA,DIU,DIY,DIW,DIV
;BEGIN CHANGES IHS/OKCAO/POC 10/12/99
;S DIE="^AUPNVMED(",DA=+$P(APSPRX(APSPX),U,4),DR=$S($P(^AUPNVMED(DA,0),U,4)]"":".04;",1:"")_".05;.06;.07" D ^DIE K DIE,DA,DR,DIY,DIW,DIU,DIV
S DIE="^AUPNVMED(",DA=+$P(APSPRX(APSPX),U,4),DR=$S($P(^AUPNVMED(DA,0),U,4)]"":".04;",1:"")_".05;.06;.07" D ^DIE K DIE,DR,DIY,DIW,DIU,DIV ;DONT KILL DA YET IHS/OKCAO/POC 6/24/98
S APSQDRUG=$TR($P($G(^AUPNVMED(DA,0)),"^",4),"-"),DIE="^AUPNVMED(",DR=".04///^S X=APSQDRUG" D ^DIE K DIE,DR,DIY,DIW,DIU,DIV,APSQDRUG ;IHS/OKCAO/POC 10/12/99
;END CHANGES IHS/OKCAO/POC 10/12/99
G E
D ;delete
D FIND
Q:'$D(APSPRX)
S (X,C)=0 K APSPC F S X=$O(APSPRX(X)) Q:X'=+X S C=C+1,APSPC(C)=X
D DISP
S DIR(0)="NO^1:"_APSPHIGH,DIR("A")="Edit which of the above" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q:$D(DIRUT)
Q:Y=""
S APSPSEL=+Y,APSPX=APSPC(APSPSEL)
S DIR(0)="Y",DIR("A")="Are you sure you want to delete this MEDICATION",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q:$D(DIRUT)
I 'Y W !,"Okay, not deleted." Q
S DIE="^AUPNVMED(",DA=+$P(APSPRX(APSPX),U,4),DR=".01///@" D ^DIE K DIE,DA,DR,DIY,DIW,DIU,DIV
;9/14/99 Version 6 Patch 2- changed APCDVLDT to APCDVDLT
;the incorrect variable was keeping the delete flag from being set
;in the AUPNVSIT global for the affected visit - next 2 lines changed
;S V=$P(APSPRX(APSPX),U,5) I '$P(^AUPNVSIT(V,0),U,9) S APCDVLDT=V D ^APCDVDLT K APCDVDLT
S V=$P(APSPRX(APSPX),U,5) I '$P(^AUPNVSIT(V,0),U,9) S APCDVDLT=V D ^APCDVDLT K APCDVDLT ;IHS/DSD/LWJ/POC 09/14/99 (fixed APCDVDLT being set)
;IHS/DSD/LWJ/POC 09/14/99 - end of fix to APCDVLDT (version 6,patch 2)
G D
Q
DISP ;display outside rx
W:$D(IOF) @IOF W !,"Outside Rx's for ",$P(^DPT(DFN,0),U)," on " S Y=APSPDATE D DD^%DT W Y,":",!
S (APSPY,APSPHIGH)=0 F S APSPY=$O(APSPC(APSPY)) Q:APSPY'=+APSPY S APSPHIGH=APSPHIGH+1,X=APSPC(APSPY) S P=APSPC(APSPY),M=+$P(APSPRX(P),U,4) D
.W !,APSPY,")",?5,"Drug Name: ",?22,$S($P(^AUPNVMED(M,0),U,4)]"":$P(^AUPNVMED(M,0),U,4),1:$P(^PSDRUG($P(^AUPNVMED(M,0),U),0),U))
.W !?5,"Where Dispensed: ",?22,$P($G(^AUPNVSIT($P(APSPRX(P),U,5),21)),U)
.W !?5,"Sig:",?22,$P(^AUPNVMED(M,0),U,5),!
.Q
Q
;
TEXT ;
;;
;;IHS PHARMACY MODULE/PCC Interface
;;
;;*******************************
;;* Update of OUTSIDE RX's *
;;*******************************
;;
APSPORXE ;IHS/TUCSON/LAB - enter outside rx [ 02/20/2001 1:51 PM ];09-Oct-2008 11:25;SM
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1,2,3,1007**;Sep 23, 2004
+2 ;
+3 ; Modified - IHS/MSC/PLS - 05/19/08 - Line FIND+1
+4 ;
START ;EP - called from option
HDR ;write header
+1 IF $DATA(IOF)
WRITE @IOF
+2 FOR J=1:1:7
SET X=$PIECE($TEXT(TEXT+J),";;",2)
WRITE !?80-$LENGTH(X)\2,X
+3 KILL X,J
+4 WRITE !!
+5 ;IHS/DSD/ENM/POC 05/11/98 NEXT THREE LINES
+6 SET X="IOBON;IOBOFF"
DO ENDR^%ZISS
+7 SET X="WARNING! NO DRUG INTERACTIONS OR CLASS CHECKING DONE IN THIS MODE"
+8 WRITE ?80-$LENGTH(X)\2,IOBON,X,IOBOFF
+9 ;
BEGIN ;
+1 IF $GET(APSPTYPE)=""
WRITE !!,$CHAR(7),$CHAR(7),"TYPE OF ACTION MISSING"
HANG 2
GOTO EXIT
+2 IF "ED"'[$GET(APSPTYPE)
WRITE !!,$CHAR(7),$CHAR(7),"TYPE OF ACTION MISSING"
HANG 2
GOTO EXIT
+3 DO INIT^APSPORXA
+4 IF APSPQUIT
GOTO EXIT
+5 DO GETPAT^APSPORXA
+6 IF DFN=""
GOTO EXIT
+7 DO GETDATE^APSPORXA
+8 IF APSPDATE=""
GOTO EXIT
+9 DO @APSPTYPE
+10 DO EXIT
+11 QUIT
EXIT ;cleanup and exit
+1 ;IHS/DSD/ENM 12/26/95 APSPDOL REMOVED
KILL APSPOIEN,APSPDRUG,APSPDIEN,APSPOL,APSPDATE,APSPQUIT,APSPSEL,APSPX,APSPRX,APSPC,APSPER,APSPHIGH,APSPTYPE,APSPY
+2 KILL M,P,V,X,Y,A,B,C,D,DIE,DIC,DIR,DTOUT,DUOUT,DIRUT,DA,DR,DIV,DIW,DIY,DIQ,DD,D0,DI,DQ,%DT,APCDVDLT,APCDVLDT
+3 DO KILL^AUPNPAT
KILL DFN,APCDPAT
+4 QUIT
FIND ;find all rx's on that date
+1 ;IHS/MSC/PLS - 05/19/08 - Updated call to PCC
+2 ;K APSPRX S Y="APSPRX(",X=DFN_"^ALL MEDS;DURING "_APSPDATE_"-"_APSPDATE S APSPER=$$^APCLDF(X,Y)
+3 KILL APSPRX
SET Y="APSPRX("
SET X=DFN_"^ALL MEDS;DURING "_APSPDATE_"-"_APSPDATE
SET APSPER=$$START1^APCLDF(X,Y)
+4 IF APSPER
WRITE !!,"ERROR in finding outside rx's - data fetcher error!!"
KILL APSPRX
QUIT
+5 SET X=0
FOR
SET X=$ORDER(APSPRX(X))
IF X'=+X
QUIT
SET V=$PIECE(APSPRX(X),U,5)
SET M=+$PIECE(APSPRX(X),U,4)
IF $PIECE(^AUPNVSIT(V,0),U,7)'="E"
KILL APSPRX(X)
+6 IF '$DATA(APSPRX)
WRITE !!,$CHAR(7),$CHAR(7),"No OUTSIDE Rx's recorded for ",$PIECE(^DPT(DFN,0),U)," on "
SET Y=APSPDATE
DO DD^%DT
WRITE Y,".",!
QUIT
+7 QUIT
E ;
+1 DO FIND
+2 IF '$DATA(APSPRX)
QUIT
+3 SET (X,C)=0
KILL APSPC
FOR
SET X=$ORDER(APSPRX(X))
IF X'=+X
QUIT
SET C=C+1
SET APSPC(C)=X
+4 DO DISP
+5 SET DIR(0)="NO^1:"_APSPHIGH
SET DIR("A")="Edit which of the above"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+6 IF $DATA(DIRUT)
QUIT
+7 IF Y=""
QUIT
+8 SET APSPSEL=+Y
SET APSPX=APSPC(APSPSEL)
SET DA=+$PIECE(APSPRX(APSPX),U,5)
SET DIE="^AUPNVSIT("
SET DR=2101
DO ^DIE
KILL DIE,DR,DA,DIU,DIY,DIW,DIV
+9 ;BEGIN CHANGES IHS/OKCAO/POC 10/12/99
+10 ;S DIE="^AUPNVMED(",DA=+$P(APSPRX(APSPX),U,4),DR=$S($P(^AUPNVMED(DA,0),U,4)]"":".04;",1:"")_".05;.06;.07" D ^DIE K DIE,DA,DR,DIY,DIW,DIU,DIV
+11 ;DONT KILL DA YET IHS/OKCAO/POC 6/24/98
SET DIE="^AUPNVMED("
SET DA=+$PIECE(APSPRX(APSPX),U,4)
SET DR=$SELECT($PIECE(^AUPNVMED(DA,0),U,4)]"":".04;",1:"")_".05;.06;.07"
DO ^DIE
KILL DIE,DR,DIY,DIW,DIU,DIV
+12 ;IHS/OKCAO/POC 10/12/99
SET APSQDRUG=$TRANSLATE($PIECE($GET(^AUPNVMED(DA,0)),"^",4),"-")
SET DIE="^AUPNVMED("
SET DR=".04///^S X=APSQDRUG"
DO ^DIE
KILL DIE,DR,DIY,DIW,DIU,DIV,APSQDRUG
+13 ;END CHANGES IHS/OKCAO/POC 10/12/99
+14 GOTO E
D ;delete
+1 DO FIND
+2 IF '$DATA(APSPRX)
QUIT
+3 SET (X,C)=0
KILL APSPC
FOR
SET X=$ORDER(APSPRX(X))
IF X'=+X
QUIT
SET C=C+1
SET APSPC(C)=X
+4 DO DISP
+5 SET DIR(0)="NO^1:"_APSPHIGH
SET DIR("A")="Edit which of the above"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+6 IF $DATA(DIRUT)
QUIT
+7 IF Y=""
QUIT
+8 SET APSPSEL=+Y
SET APSPX=APSPC(APSPSEL)
+9 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to delete this MEDICATION"
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+10 IF $DATA(DIRUT)
QUIT
+11 IF 'Y
WRITE !,"Okay, not deleted."
QUIT
+12 SET DIE="^AUPNVMED("
SET DA=+$PIECE(APSPRX(APSPX),U,4)
SET DR=".01///@"
DO ^DIE
KILL DIE,DA,DR,DIY,DIW,DIU,DIV
+13 ;9/14/99 Version 6 Patch 2- changed APCDVLDT to APCDVDLT
+14 ;the incorrect variable was keeping the delete flag from being set
+15 ;in the AUPNVSIT global for the affected visit - next 2 lines changed
+16 ;S V=$P(APSPRX(APSPX),U,5) I '$P(^AUPNVSIT(V,0),U,9) S APCDVLDT=V D ^APCDVDLT K APCDVDLT
+17 ;IHS/DSD/LWJ/POC 09/14/99 (fixed APCDVDLT being set)
SET V=$PIECE(APSPRX(APSPX),U,5)
IF '$PIECE(^AUPNVSIT(V,0),U,9)
SET APCDVDLT=V
DO ^APCDVDLT
KILL APCDVDLT
+18 ;IHS/DSD/LWJ/POC 09/14/99 - end of fix to APCDVLDT (version 6,patch 2)
+19 GOTO D
+20 QUIT
DISP ;display outside rx
+1 IF $DATA(IOF)
WRITE @IOF
WRITE !,"Outside Rx's for ",$PIECE(^DPT(DFN,0),U)," on "
SET Y=APSPDATE
DO DD^%DT
WRITE Y,":",!
+2 SET (APSPY,APSPHIGH)=0
FOR
SET APSPY=$ORDER(APSPC(APSPY))
IF APSPY'=+APSPY
QUIT
SET APSPHIGH=APSPHIGH+1
SET X=APSPC(APSPY)
SET P=APSPC(APSPY)
SET M=+$PIECE(APSPRX(P),U,4)
Begin DoDot:1
+3 WRITE !,APSPY,")",?5,"Drug Name: ",?22,$SELECT($PIECE(^AUPNVMED(M,0),U,4)]"":$PIECE(^AUPNVMED(M,0),U,4),1:$PIECE(^PSDRUG($PIECE(^AUPNVMED(M,0),U),0),U))
+4 WRITE !?5,"Where Dispensed: ",?22,$PIECE($GET(^AUPNVSIT($PIECE(APSPRX(P),U,5),21)),U)
+5 WRITE !?5,"Sig:",?22,$PIECE(^AUPNVMED(M,0),U,5),!
+6 QUIT
End DoDot:1
+7 QUIT
+8 ;
TEXT ;
+1 ;;
+2 ;;IHS PHARMACY MODULE/PCC Interface
+3 ;;
+4 ;;*******************************
+5 ;;* Update of OUTSIDE RX's *
+6 ;;*******************************
+7 ;;
