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