MCARSUP ;WISC/TJK-MEDICINE PACKAGE MANAGEMENT OPTIONS ;7/2/92 10:23
V ;;2.3;Medicine;;09/13/1996
EN1 ;
1 Q:'$D(MCARCODE) S DIC="^MCAR(695,",DLAYGO=695,DIC(0)="AEQLM" D ^DIC G OUT1:Y<0 S DA=+Y G DEL:$D(^MCAR(695,"C",MCARCODE,+Y)) S DR="1///"_MCARCODE,DIE=DIC K DIC,DLAYGO D ^DIE K DIE,DA,DR
W !,*7,"Drug marked as a ",$S(MCARCODE="G":"GI",MCARCODE="P":"PULMONARY",MCARCODE="R":"RHEUMATOLOGY",1:"CARDIOLOGY")," Drug" G 1
EN2 ;
2 S DIC="^MCAR(693.6,",(DIDEL,DLAYGO)=693.6,DIC(0)="AEQLM" D ^DIC G OUT1:Y<0 S DA=+Y,DR=.01,DIE=DIC K DIC,DLAYGO D ^DIE K DA,DIE,DR G 2
EN3 ;
3 Q:'$D(DIC) S MCDICS=DIC("S"),DIC(0)="AEQLM" D ^DIC G OUT1:Y<0 S DA=+Y,DR=.01,DIE=DIC,DIDEL=DLAYGO D ^DIE K DA S DIC("S")=MCDICS G 3
DEL K DIC,DA,DLAYGO,DIR
S DA(1)=+Y
S DIR("A",1)="Drug already marked as a "_$S(MCARCODE="G":"GI",MCARCODE="P":"PULMONARY",MCARCODE="R":"RHEUMATOLOGY",1:"CARDIOLOGY")_" Drug."
S DIR("A")="Do you wish to delete it",DIR("B")="N",DIR(0)="Y"
D ^DIR
I Y S DA=$O(^MCAR(695,"C",MCARCODE,DA(1),0)),DIK="^MCAR(695,"_DA(1)_",1," D ^DIK K DA,DIK,%,Y,X W !!,"Deleted"
G 1
OUT1 K %,%H,C,D0,DI,DIG,DIH,DIU,DIV,DIW,DQ,I,Z,Y,X,DIC,DLAYGO,DIE,MCARCODE,%Y,DR,DQ,D1,%Y1,%Y2,DICMX,DIPGM,DIXX,VA,DIDEL,MCDICS Q
HELP ;DISPLAY LIST OF DRUGS ALREADY MARKED
IF $D(^MCAR(695,"C",$G(MCARCODE,U))) D ;JCC,5/15/96
. S DIR("A")="Do you wish to see list of drugs already marked for this area of Medicine"
. S DIR("B")="N",DIR(0)="Y"
. D ^DIR
. IF Y D
.. W !!,"Drugs already marked for this area of Medicine: ",!
.. F I=0:0 S I=$O(^MCAR(695,"C",MCARCODE,I)) Q:I="" W:$X>50 ! W $E($P(^PSDRUG(I,0),U)_" ",1,40)
.. Q
. ;END IF
. ;
. Q
;END IF
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARSUP 1725 printed Dec 13, 2024@02:14:34 Page 2
MCARSUP ;WISC/TJK-MEDICINE PACKAGE MANAGEMENT OPTIONS ;7/2/92 10:23
V ;;2.3;Medicine;;09/13/1996
EN1 ;
1 if '$DATA(MCARCODE)
QUIT
SET DIC="^MCAR(695,"
SET DLAYGO=695
SET DIC(0)="AEQLM"
DO ^DIC
if Y<0
GOTO OUT1
SET DA=+Y
if $DATA(^MCAR(695,"C",MCARCODE,+Y))
GOTO DEL
SET DR="1///"_MCARCODE
SET DIE=DIC
KILL DIC,DLAYGO
DO ^DIE
KILL DIE,DA,DR
+1 WRITE !,*7,"Drug marked as a ",$SELECT(MCARCODE="G":"GI",MCARCODE="P":"PULMONARY",MCARCODE="R":"RHEUMATOLOGY",1:"CARDIOLOGY")," Drug"
GOTO 1
EN2 ;
2 SET DIC="^MCAR(693.6,"
SET (DIDEL,DLAYGO)=693.6
SET DIC(0)="AEQLM"
DO ^DIC
if Y<0
GOTO OUT1
SET DA=+Y
SET DR=.01
SET DIE=DIC
KILL DIC,DLAYGO
DO ^DIE
KILL DA,DIE,DR
GOTO 2
EN3 ;
3 if '$DATA(DIC)
QUIT
SET MCDICS=DIC("S")
SET DIC(0)="AEQLM"
DO ^DIC
if Y<0
GOTO OUT1
SET DA=+Y
SET DR=.01
SET DIE=DIC
SET DIDEL=DLAYGO
DO ^DIE
KILL DA
SET DIC("S")=MCDICS
GOTO 3
DEL KILL DIC,DA,DLAYGO,DIR
+1 SET DA(1)=+Y
+2 SET DIR("A",1)="Drug already marked as a "_$SELECT(MCARCODE="G":"GI",MCARCODE="P":"PULMONARY",MCARCODE="R":"RHEUMATOLOGY",1:"CARDIOLOGY")_" Drug."
+3 SET DIR("A")="Do you wish to delete it"
SET DIR("B")="N"
SET DIR(0)="Y"
+4 DO ^DIR
+5 IF Y
SET DA=$ORDER(^MCAR(695,"C",MCARCODE,DA(1),0))
SET DIK="^MCAR(695,"_DA(1)_",1,"
DO ^DIK
KILL DA,DIK,%,Y,X
WRITE !!,"Deleted"
+6 GOTO 1
OUT1 KILL %,%H,C,D0,DI,DIG,DIH,DIU,DIV,DIW,DQ,I,Z,Y,X,DIC,DLAYGO,DIE,MCARCODE,%Y,DR,DQ,D1,%Y1,%Y2,DICMX,DIPGM,DIXX,VA,DIDEL,MCDICS
QUIT
HELP ;DISPLAY LIST OF DRUGS ALREADY MARKED
+1 ;JCC,5/15/96
IF $DATA(^MCAR(695,"C",$GET(MCARCODE,U)))
Begin DoDot:1
+2 SET DIR("A")="Do you wish to see list of drugs already marked for this area of Medicine"
+3 SET DIR("B")="N"
SET DIR(0)="Y"
+4 DO ^DIR
+5 IF Y
Begin DoDot:2
+6 WRITE !!,"Drugs already marked for this area of Medicine: ",!
+7 FOR I=0:0
SET I=$ORDER(^MCAR(695,"C",MCARCODE,I))
if I=""
QUIT
if $X>50
WRITE !
WRITE $EXTRACT($PIECE(^PSDRUG(I,0),U)_" ",1,40)
+8 QUIT
End DoDot:2
+9 ;END IF
+10 ;
+11 QUIT
End DoDot:1
+12 ;END IF
+13 ;
+14 QUIT
