APSPORXE.m

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       ;;