- 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 Feb 18, 2025@23:41:02 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