- MMRSIPCP ;MIA/LMT/TCK,LAB - SETUP MDRO TOOLS SOFTWARE PARAMETERS ;May 22, 2019@09:15:23
- ;;1.0;MRSA PROGRAM TOOLS;**1,3,4,8,9**;Mar 22, 2009;Build 1
- ;
- DIV ;Add a division and setup business rules
- N DIC,X,DINUM,DLAYGO,MMRSDIV,DIR,DIE,DA,DR,DIDEL,Y
- S DIC="^MMRS(104,"
- S DIC(0)="AELMQ"
- S DIC("A")="Select MRSA Site Parameters Division: "
- S DLAYGO=104
- D ^DIC
- K DLAYGO
- I $D(DTOUT)!($D(DUOUT))!(Y=-1) S EXTFLG=1 Q
- S MMRSDIV=+Y
- W !!
- ;RECEIVING UNIT SCREEN
- S DA=MMRSDIV
- S DIR("A")="1. Receiving unit screen on unit-to-unit transfers"
- S DIR(0)="104,1"
- D ^DIR
- I $D(DTOUT)!($D(DUOUT)) S EXTFLG=1 Q
- S DIE="^MMRS(104,"
- S DA=MMRSDIV
- S Y=+$P(Y,U,1)
- S DR="1///"_Y ;MMRS*1.0*8
- I Y=1!(Y=0) D ^DIE
- ;DISCHARGING UNIT SCREEN
- S DA=MMRSDIV
- S DIR("A")="2. Discharging unit screen on unit-to-unit transfers"
- S DIR(0)="104,2"
- D ^DIR
- I $D(DTOUT)!($D(DUOUT)) S EXTFLG=1 Q
- S DIE="^MMRS(104,"
- S DA=MMRSDIV
- S Y=+$P(Y,U,1)
- S DR="2///"_Y ;MMRS*1.0*8
- I Y=1!(Y=0) D ^DIE
- ;SCREEN POS ON TRANSFER IN
- S DA=MMRSDIV
- S DIR("A")="3. Screen patients with MRSA history on transfer-in"
- S DIR(0)="104,3"
- D ^DIR
- I $D(DTOUT)!($D(DUOUT)) S EXTFLG=1 Q
- S DIE="^MMRS(104,"
- S DA=MMRSDIV
- S Y=+$P(Y,U,1)
- S DR="3///"_Y ;MMRS*1.0*8
- I Y=1!(Y=0) D ^DIE
- ;SCREEN POS ON DISCHARGE
- S DA=MMRSDIV
- S DIR("A")="4. Screen patients with MRSA history on discharge/death/transfer-out"
- S DIR(0)="104,4"
- D ^DIR
- I $D(DTOUT)!($D(DUOUT)) S EXTFLG=1 Q
- S DIE="^MMRS(104,"
- S DA=MMRSDIV
- S Y=+$P(Y,U,1)
- S DR="4///"_Y ;MMRS*1.0*8
- I Y=1!(Y=0) D ^DIE
- Q
- ;
- FLESPC ;
- ;Add a division and setup business rules
- N DIC,X,DINUM,DLAYGO,MMRSDIV,DIR,DIE,DA,DR,DIDEL,Y
- S DIC="^MMRS(104,"
- S DIC(0)="AELMQ"
- S DIC("A")="Select CRE Site Parameters Division: "
- S DLAYGO=104
- D ^DIC
- K DLAYGO
- I $D(DTOUT)!($D(DUOUT))!(Y=-1) S EXTFLG=1 Q
- S MMRSDIV=+Y
- W !!
- ;ADD SURVEILLANCE SCREEN SPECIMENS
- N STID,STNM,SIEN
- S DIR(0)="YA",DIR("A")="Do you want to Add or Edit specimen(s) for CRE Surveillance Screens"
- S DIR(0)="S^A:ADD;E:EDIT"
- S DIR("B")="E"
- D ^DIR
- Q:X=""!($D(DIRUT))!($D(DIROUT))
- ;I $D(DIRUT) S EXTFLG=1 Q
- I Y Q
- S STOP=0
- N DIC,DLAYGO,DTOUT,DUOUT,EXTFLG
- S EXTFLG=0
- G:Y="A" ADD
- ;
- DEL ;
- S EXTFLG=0
- W !
- S DA(1)=MMRSDIV
- K DIR S DIR("A")="Select Specimen to delete"
- S DIR("?")="Enter the specimen you want to edit"
- S DIR(0)="PO^MMRS(104,DA(1),61,:QEMO"
- D ^DIR
- I Y["^" D
- .S DA(1)=MMRSDIV
- .S DA=$P(Y,"^")
- .S DIK="^MMRS(104,"_DA(1)_",61,"
- .D ^DIK
- I $P(Y,"^",2)'="" G DEL
- K DIK,DA
- Q
- ;
- ADD ;
- K DIR S DIR("A")="Select Specimen"
- S DIR(0)="P^61:QEM"
- S DA(1)=MMRSDIV
- D ^DIR
- I (Y=-1)!($D(DTOUT))!($D(DUOUT)) S EXTFLG=1 Q
- S X=$P(Y,"^"),VAL=X
- I $D(^MMRS(104,"AC",DA(1),X)) D G FLESPC
- .W !!!!,$P(Y,"^",2)_" already exists." H 1 Q
- S IEN="?+1,"_DA(1)_","
- S LRFDA(61,104.0216061,IEN,.01)=VAL
- D UPDATE^DIE("","LRFDA(61)","","LRMSG")
- I 'EXTFLG G FLESPC
- Q
- ;
- ;
- LAB ;Entry to setup the Lab Search/Extract Parameters
- N EXTFLG,MMRSDIV,MDRO,DA,DO,DIC,DINUM,X,Y,DDSFILE,DR,DDSPAGE,DDSPARAM,DIR
- D CHECK^MMRSIPC
- I $D(EXTFLG) W ! H 2 Q
- W !
- S MMRSDIV=$$GETDIV^MMRSIPC Q:$D(EXTFLG)!(MMRSDIV="")
- W !
- S MDRO=$$GETMDRO Q:$D(EXTFLG)
- W !
- S DIR(0)="Y",DIR("B")="YES",DIR("A")="Do you want to see a description for "_$$GET1^DIQ(104.2,MDRO,.01)
- D ^DIR
- I $D(DTOUT)!($D(DUOUT)) S EXTFLG=1 Q
- I Y=1 D
- .N DIC,DA,DR,DIQ,DIR
- .W @IOF
- .S DIC="^MMRS(104.2,"
- .S DA=MDRO
- .S DR=2
- .D EN^DIQ
- .S DIR(0)="E",DIR("A")="Enter RETURN to continue" D ^DIR
- W !
- S DA=$O(^MMRS(104.1,"C",MMRSDIV,MDRO,0))
- I 'DA D Q:$D(EXTFLG)!('DA)
- .K DA
- .S DIC="^MMRS(104.1,"
- .S DIC(0)="F"
- .S X=MDRO
- .S DIC("DR")="1////"_MMRSDIV ;MMRS*1.0*9
- .D FILE^DICN
- .I Y=-1 S EXTFLG=1 Q
- .S DA=+Y
- S DDSFILE="^MMRS(104.1,"
- S DR="[MMRSLABPARAM]"
- D ^DDS
- Q
- GETMDRO() ;
- N MDRO,DIC,DLAYGO,DINUM,Y,DLAYGO,X,DTOUT,DUOUT
- S MDRO=""
- S DIC="^MMRS(104.2,"
- S DIC(0)="AEMNQ"
- S DIC("A")="Select the MDRO: "
- D ^DIC K DIC
- I $D(DTOUT)!($D(DUOUT))!(Y=-1) S EXTFLG=1 Q ""
- S MDRO=+Y
- Q MDRO
- WARDMAP ;Entry to setup the Ward Mappings
- N MMRSDIV,DIC,Y,DLAYGO,DINUM,X,DTOUT,DUOUT,DDSFILE,DR,DA,DDSPAGE,DDSPARAM,EXTFLG,DIE,DIDEL,MMRSDA
- D CHECK^MMRSIPC
- I $D(EXTFLG) W ! H 2 Q
- W !
- S MMRSDIV=$$GETDIV^MMRSIPC Q:$D(EXTFLG)!(MMRSDIV="")
- F Q:$D(EXTFLG) D
- .S DIC="^MMRS(104.3,"
- .S DIC(0)="AELMQ"
- .S DIC("A")="Select Geographical Unit: "
- .S DIC("DR")="1////"_MMRSDIV_";3;4" ;MMRS*1.0*9
- .S DLAYGO=104.3
- .W !! D ^DIC
- .K DLAYGO
- .I $D(DTOUT)!($D(DUOUT))!(Y=-1) S EXTFLG=1 Q
- .S MMRSDA=+Y
- .I '$P(Y,U,3) D
- ..S DIE="^MMRS(104.3,"
- ..S DA=MMRSDA
- ..S DR=".01;3;4"
- ..S DIDEL=104.3
- ..W !
- ..D ^DIE
- ..I $D(DTOUT)!('$D(DA)) S EXTFLG=1 Q
- .Q:$D(EXTFLG)
- .S DDSFILE="^MMRS(104.3,"
- .S DR="[MMRSMRSA WARD MAP]"
- .S DA=MMRSDA
- .D ^DDS
- .W @IOF
- Q
- HISTDAY ;Historical Days Edit
- N EXTFLG,MMRSDIV,MDRO,DA,DO,DIC,DINUM,X,Y,DIR,NUMDAY,MMRSX,DIE,DR,DIDEL,DIRUT,DTOUT,DUOUT
- D CHECK^MMRSIPC
- I $D(EXTFLG) W ! H 2 Q
- W ! S MMRSDIV=$$GETDIV^MMRSIPC Q:$D(EXTFLG)!(MMRSDIV="")
- W !
- S MDRO=0 F S MDRO=$O(^MMRS(104.2,MDRO)) Q:'MDRO D Q:$D(EXTFLG)
- .S DA=$O(^MMRS(104.2,MDRO,1,"B",MMRSDIV,0))
- .I 'DA D Q:$D(EXTFLG)!('DA)
- ..K DA
- ..S DIC="^MMRS(104.2,"_MDRO_",1,"
- ..S DIC(0)="F"
- ..S DA(1)=MDRO
- ..S X=MMRSDIV
- ..D FILE^DICN
- ..I Y=-1 S EXTFLG=1 Q
- ..S DA=+Y
- .S DA(1)=MDRO
- .S DIR(0)="104.22,1^AO"
- .S DIR("PRE")="I X=""@"" S X=9876 S MMRSX=9876"
- .S DIR("A")="Enter the number of days to search for "_$P($G(^MMRS(104.2,MDRO,0)),U,1)
- .D ^DIR
- .I $D(DTOUT)!($D(DUOUT)) S EXTFLG=1 Q
- .I Y D
- ..S DIE="^MMRS(104.2,"_MDRO_",1,"
- ..I $G(MMRSX)'=9876 S DR="1///"_+Y ;MMRS*1.0*8
- ..I Y=9876,($G(MMRSX)=9876) S DR="1////@"
- ..K MMRSX
- ..D ^DIE
- ..I $D(Y) S EXTFLG=1 Q ;MMRS*1.0*8
- W !
- Q
- ISLTORD ;Entry to setup the Isolation Orders Parameters
- N EXTFLG,MMRSDIV,DA,DDSFILE,DR,DDSPAGE,DDSPARAM
- D CHECK^MMRSIPC
- I $D(EXTFLG) W ! H 2 Q
- W !
- S MMRSDIV=$$GETDIV^MMRSIPC Q:$D(EXTFLG)!(MMRSDIV="")
- W !
- S DA=MMRSDIV
- S DDSFILE="^MMRS(104,"
- S DR="[MMRSISLTORD]"
- D ^DDS
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMMRSIPCP 6120 printed Jan 18, 2025@03:16:20 Page 2
- MMRSIPCP ;MIA/LMT/TCK,LAB - SETUP MDRO TOOLS SOFTWARE PARAMETERS ;May 22, 2019@09:15:23
- +1 ;;1.0;MRSA PROGRAM TOOLS;**1,3,4,8,9**;Mar 22, 2009;Build 1
- +2 ;
- DIV ;Add a division and setup business rules
- +1 NEW DIC,X,DINUM,DLAYGO,MMRSDIV,DIR,DIE,DA,DR,DIDEL,Y
- +2 SET DIC="^MMRS(104,"
- +3 SET DIC(0)="AELMQ"
- +4 SET DIC("A")="Select MRSA Site Parameters Division: "
- +5 SET DLAYGO=104
- +6 DO ^DIC
- +7 KILL DLAYGO
- +8 IF $DATA(DTOUT)!($DATA(DUOUT))!(Y=-1)
- SET EXTFLG=1
- QUIT
- +9 SET MMRSDIV=+Y
- +10 WRITE !!
- +11 ;RECEIVING UNIT SCREEN
- +12 SET DA=MMRSDIV
- +13 SET DIR("A")="1. Receiving unit screen on unit-to-unit transfers"
- +14 SET DIR(0)="104,1"
- +15 DO ^DIR
- +16 IF $DATA(DTOUT)!($DATA(DUOUT))
- SET EXTFLG=1
- QUIT
- +17 SET DIE="^MMRS(104,"
- +18 SET DA=MMRSDIV
- +19 SET Y=+$PIECE(Y,U,1)
- +20 ;MMRS*1.0*8
- SET DR="1///"_Y
- +21 IF Y=1!(Y=0)
- DO ^DIE
- +22 ;DISCHARGING UNIT SCREEN
- +23 SET DA=MMRSDIV
- +24 SET DIR("A")="2. Discharging unit screen on unit-to-unit transfers"
- +25 SET DIR(0)="104,2"
- +26 DO ^DIR
- +27 IF $DATA(DTOUT)!($DATA(DUOUT))
- SET EXTFLG=1
- QUIT
- +28 SET DIE="^MMRS(104,"
- +29 SET DA=MMRSDIV
- +30 SET Y=+$PIECE(Y,U,1)
- +31 ;MMRS*1.0*8
- SET DR="2///"_Y
- +32 IF Y=1!(Y=0)
- DO ^DIE
- +33 ;SCREEN POS ON TRANSFER IN
- +34 SET DA=MMRSDIV
- +35 SET DIR("A")="3. Screen patients with MRSA history on transfer-in"
- +36 SET DIR(0)="104,3"
- +37 DO ^DIR
- +38 IF $DATA(DTOUT)!($DATA(DUOUT))
- SET EXTFLG=1
- QUIT
- +39 SET DIE="^MMRS(104,"
- +40 SET DA=MMRSDIV
- +41 SET Y=+$PIECE(Y,U,1)
- +42 ;MMRS*1.0*8
- SET DR="3///"_Y
- +43 IF Y=1!(Y=0)
- DO ^DIE
- +44 ;SCREEN POS ON DISCHARGE
- +45 SET DA=MMRSDIV
- +46 SET DIR("A")="4. Screen patients with MRSA history on discharge/death/transfer-out"
- +47 SET DIR(0)="104,4"
- +48 DO ^DIR
- +49 IF $DATA(DTOUT)!($DATA(DUOUT))
- SET EXTFLG=1
- QUIT
- +50 SET DIE="^MMRS(104,"
- +51 SET DA=MMRSDIV
- +52 SET Y=+$PIECE(Y,U,1)
- +53 ;MMRS*1.0*8
- SET DR="4///"_Y
- +54 IF Y=1!(Y=0)
- DO ^DIE
- +55 QUIT
- +56 ;
- FLESPC ;
- +1 ;Add a division and setup business rules
- +2 NEW DIC,X,DINUM,DLAYGO,MMRSDIV,DIR,DIE,DA,DR,DIDEL,Y
- +3 SET DIC="^MMRS(104,"
- +4 SET DIC(0)="AELMQ"
- +5 SET DIC("A")="Select CRE Site Parameters Division: "
- +6 SET DLAYGO=104
- +7 DO ^DIC
- +8 KILL DLAYGO
- +9 IF $DATA(DTOUT)!($DATA(DUOUT))!(Y=-1)
- SET EXTFLG=1
- QUIT
- +10 SET MMRSDIV=+Y
- +11 WRITE !!
- +12 ;ADD SURVEILLANCE SCREEN SPECIMENS
- +13 NEW STID,STNM,SIEN
- +14 SET DIR(0)="YA"
- SET DIR("A")="Do you want to Add or Edit specimen(s) for CRE Surveillance Screens"
- +15 SET DIR(0)="S^A:ADD;E:EDIT"
- +16 SET DIR("B")="E"
- +17 DO ^DIR
- +18 if X=""!($DATA(DIRUT))!($DATA(DIROUT))
- QUIT
- +19 ;I $D(DIRUT) S EXTFLG=1 Q
- +20 IF Y
- QUIT
- +21 SET STOP=0
- +22 NEW DIC,DLAYGO,DTOUT,DUOUT,EXTFLG
- +23 SET EXTFLG=0
- +24 if Y="A"
- GOTO ADD
- +25 ;
- DEL ;
- +1 SET EXTFLG=0
- +2 WRITE !
- +3 SET DA(1)=MMRSDIV
- +4 KILL DIR
- SET DIR("A")="Select Specimen to delete"
- +5 SET DIR("?")="Enter the specimen you want to edit"
- +6 SET DIR(0)="PO^MMRS(104,DA(1),61,:QEMO"
- +7 DO ^DIR
- +8 IF Y["^"
- Begin DoDot:1
- +9 SET DA(1)=MMRSDIV
- +10 SET DA=$PIECE(Y,"^")
- +11 SET DIK="^MMRS(104,"_DA(1)_",61,"
- +12 DO ^DIK
- End DoDot:1
- +13 IF $PIECE(Y,"^",2)'=""
- GOTO DEL
- +14 KILL DIK,DA
- +15 QUIT
- +16 ;
- ADD ;
- +1 KILL DIR
- SET DIR("A")="Select Specimen"
- +2 SET DIR(0)="P^61:QEM"
- +3 SET DA(1)=MMRSDIV
- +4 DO ^DIR
- +5 IF (Y=-1)!($DATA(DTOUT))!($DATA(DUOUT))
- SET EXTFLG=1
- QUIT
- +6 SET X=$PIECE(Y,"^")
- SET VAL=X
- +7 IF $DATA(^MMRS(104,"AC",DA(1),X))
- Begin DoDot:1
- +8 WRITE !!!!,$PIECE(Y,"^",2)_" already exists."
- HANG 1
- QUIT
- End DoDot:1
- GOTO FLESPC
- +9 SET IEN="?+1,"_DA(1)_","
- +10 SET LRFDA(61,104.0216061,IEN,.01)=VAL
- +11 DO UPDATE^DIE("","LRFDA(61)","","LRMSG")
- +12 IF 'EXTFLG
- GOTO FLESPC
- +13 QUIT
- +14 ;
- +15 ;
- LAB ;Entry to setup the Lab Search/Extract Parameters
- +1 NEW EXTFLG,MMRSDIV,MDRO,DA,DO,DIC,DINUM,X,Y,DDSFILE,DR,DDSPAGE,DDSPARAM,DIR
- +2 DO CHECK^MMRSIPC
- +3 IF $DATA(EXTFLG)
- WRITE !
- HANG 2
- QUIT
- +4 WRITE !
- +5 SET MMRSDIV=$$GETDIV^MMRSIPC
- if $DATA(EXTFLG)!(MMRSDIV="")
- QUIT
- +6 WRITE !
- +7 SET MDRO=$$GETMDRO
- if $DATA(EXTFLG)
- QUIT
- +8 WRITE !
- +9 SET DIR(0)="Y"
- SET DIR("B")="YES"
- SET DIR("A")="Do you want to see a description for "_$$GET1^DIQ(104.2,MDRO,.01)
- +10 DO ^DIR
- +11 IF $DATA(DTOUT)!($DATA(DUOUT))
- SET EXTFLG=1
- QUIT
- +12 IF Y=1
- Begin DoDot:1
- +13 NEW DIC,DA,DR,DIQ,DIR
- +14 WRITE @IOF
- +15 SET DIC="^MMRS(104.2,"
- +16 SET DA=MDRO
- +17 SET DR=2
- +18 DO EN^DIQ
- +19 SET DIR(0)="E"
- SET DIR("A")="Enter RETURN to continue"
- DO ^DIR
- End DoDot:1
- +20 WRITE !
- +21 SET DA=$ORDER(^MMRS(104.1,"C",MMRSDIV,MDRO,0))
- +22 IF 'DA
- Begin DoDot:1
- +23 KILL DA
- +24 SET DIC="^MMRS(104.1,"
- +25 SET DIC(0)="F"
- +26 SET X=MDRO
- +27 ;MMRS*1.0*9
- SET DIC("DR")="1////"_MMRSDIV
- +28 DO FILE^DICN
- +29 IF Y=-1
- SET EXTFLG=1
- QUIT
- +30 SET DA=+Y
- End DoDot:1
- if $DATA(EXTFLG)!('DA)
- QUIT
- +31 SET DDSFILE="^MMRS(104.1,"
- +32 SET DR="[MMRSLABPARAM]"
- +33 DO ^DDS
- +34 QUIT
- GETMDRO() ;
- +1 NEW MDRO,DIC,DLAYGO,DINUM,Y,DLAYGO,X,DTOUT,DUOUT
- +2 SET MDRO=""
- +3 SET DIC="^MMRS(104.2,"
- +4 SET DIC(0)="AEMNQ"
- +5 SET DIC("A")="Select the MDRO: "
- +6 DO ^DIC
- KILL DIC
- +7 IF $DATA(DTOUT)!($DATA(DUOUT))!(Y=-1)
- SET EXTFLG=1
- QUIT ""
- +8 SET MDRO=+Y
- +9 QUIT MDRO
- WARDMAP ;Entry to setup the Ward Mappings
- +1 NEW MMRSDIV,DIC,Y,DLAYGO,DINUM,X,DTOUT,DUOUT,DDSFILE,DR,DA,DDSPAGE,DDSPARAM,EXTFLG,DIE,DIDEL,MMRSDA
- +2 DO CHECK^MMRSIPC
- +3 IF $DATA(EXTFLG)
- WRITE !
- HANG 2
- QUIT
- +4 WRITE !
- +5 SET MMRSDIV=$$GETDIV^MMRSIPC
- if $DATA(EXTFLG)!(MMRSDIV="")
- QUIT
- +6 FOR
- if $DATA(EXTFLG)
- QUIT
- Begin DoDot:1
- +7 SET DIC="^MMRS(104.3,"
- +8 SET DIC(0)="AELMQ"
- +9 SET DIC("A")="Select Geographical Unit: "
- +10 ;MMRS*1.0*9
- SET DIC("DR")="1////"_MMRSDIV_";3;4"
- +11 SET DLAYGO=104.3
- +12 WRITE !!
- DO ^DIC
- +13 KILL DLAYGO
- +14 IF $DATA(DTOUT)!($DATA(DUOUT))!(Y=-1)
- SET EXTFLG=1
- QUIT
- +15 SET MMRSDA=+Y
- +16 IF '$PIECE(Y,U,3)
- Begin DoDot:2
- +17 SET DIE="^MMRS(104.3,"
- +18 SET DA=MMRSDA
- +19 SET DR=".01;3;4"
- +20 SET DIDEL=104.3
- +21 WRITE !
- +22 DO ^DIE
- +23 IF $DATA(DTOUT)!('$DATA(DA))
- SET EXTFLG=1
- QUIT
- End DoDot:2
- +24 if $DATA(EXTFLG)
- QUIT
- +25 SET DDSFILE="^MMRS(104.3,"
- +26 SET DR="[MMRSMRSA WARD MAP]"
- +27 SET DA=MMRSDA
- +28 DO ^DDS
- +29 WRITE @IOF
- End DoDot:1
- +30 QUIT
- HISTDAY ;Historical Days Edit
- +1 NEW EXTFLG,MMRSDIV,MDRO,DA,DO,DIC,DINUM,X,Y,DIR,NUMDAY,MMRSX,DIE,DR,DIDEL,DIRUT,DTOUT,DUOUT
- +2 DO CHECK^MMRSIPC
- +3 IF $DATA(EXTFLG)
- WRITE !
- HANG 2
- QUIT
- +4 WRITE !
- SET MMRSDIV=$$GETDIV^MMRSIPC
- if $DATA(EXTFLG)!(MMRSDIV="")
- QUIT
- +5 WRITE !
- +6 SET MDRO=0
- FOR
- SET MDRO=$ORDER(^MMRS(104.2,MDRO))
- if 'MDRO
- QUIT
- Begin DoDot:1
- +7 SET DA=$ORDER(^MMRS(104.2,MDRO,1,"B",MMRSDIV,0))
- +8 IF 'DA
- Begin DoDot:2
- +9 KILL DA
- +10 SET DIC="^MMRS(104.2,"_MDRO_",1,"
- +11 SET DIC(0)="F"
- +12 SET DA(1)=MDRO
- +13 SET X=MMRSDIV
- +14 DO FILE^DICN
- +15 IF Y=-1
- SET EXTFLG=1
- QUIT
- +16 SET DA=+Y
- End DoDot:2
- if $DATA(EXTFLG)!('DA)
- QUIT
- +17 SET DA(1)=MDRO
- +18 SET DIR(0)="104.22,1^AO"
- +19 SET DIR("PRE")="I X=""@"" S X=9876 S MMRSX=9876"
- +20 SET DIR("A")="Enter the number of days to search for "_$PIECE($GET(^MMRS(104.2,MDRO,0)),U,1)
- +21 DO ^DIR
- +22 IF $DATA(DTOUT)!($DATA(DUOUT))
- SET EXTFLG=1
- QUIT
- +23 IF Y
- Begin DoDot:2
- +24 SET DIE="^MMRS(104.2,"_MDRO_",1,"
- +25 ;MMRS*1.0*8
- IF $GET(MMRSX)'=9876
- SET DR="1///"_+Y
- +26 IF Y=9876
- IF ($GET(MMRSX)=9876)
- SET DR="1////@"
- +27 KILL MMRSX
- +28 DO ^DIE
- +29 ;MMRS*1.0*8
- IF $DATA(Y)
- SET EXTFLG=1
- QUIT
- End DoDot:2
- End DoDot:1
- if $DATA(EXTFLG)
- QUIT
- +30 WRITE !
- +31 QUIT
- ISLTORD ;Entry to setup the Isolation Orders Parameters
- +1 NEW EXTFLG,MMRSDIV,DA,DDSFILE,DR,DDSPAGE,DDSPARAM
- +2 DO CHECK^MMRSIPC
- +3 IF $DATA(EXTFLG)
- WRITE !
- HANG 2
- QUIT
- +4 WRITE !
- +5 SET MMRSDIV=$$GETDIV^MMRSIPC
- if $DATA(EXTFLG)!(MMRSDIV="")
- QUIT
- +6 WRITE !
- +7 SET DA=MMRSDIV
- +8 SET DDSFILE="^MMRS(104,"
- +9 SET DR="[MMRSISLTORD]"
- +10 DO ^DDS
- +11 QUIT