- PSNPPSNR ;HP/AF-CONF option continued ; 05 Mar 2014 1:20 PM
- ;;4.0;NATIONAL DRUG FILE;**513**; 30 Oct 98;Build 53
- ;External reference to ^ORD(101 supported by DBIA #872
- ;External reference ^DIC(19.2 supported by DBIA #1472
- ;Reference to ^DIC(19 supported by DBIA #2246
- ;Reference to ^DIC(19.2 supported by DBIA #2910
- ;Reference to ^ORD( supported by DBIA #872
- ;
- ;Mark Scheduled options, menu options, and protocol out of order.
- ;Used by UPDT - Begin update of NDF data from PPS-N option during install of PPS-N/NDF Update file.
- DISOPTS ;
- N DIRUT,DUOUT,DIR,X,Y,PPG,DA,DIC,DIE,DR,DUOUT,DIRUT,PPSN
- S (Y,X,PPG)="",DIR(0)="Y",DIR("?")="Please enter Y or N."
- S DIR("A")="Do you want to DISABLE Scheduled Options, Menu Options and Protocols"
- S DIR("B")="YES"
- D ^DIR
- Q:Y="^"!("Nn"[Y)!('Y)!$G(DIRUT)!$G(DTOUT)
- F D DISSO Q:PPG=""!$G(DIRUT)!$G(DTOUT)
- F D DISMO Q:PPG=""!$G(DIRUT)!$G(DTOUT)
- F D DISPR Q:PPG=""!$G(DIRUT)!$G(DTOUT)
- K ^TMP("PSNPPSNR",$J)
- Q
- ;
- DISSO ;
- N DIC,DIK,DR,DIR,DA,I,II,III,IV,ICNT,X,Y,DIE,DTOUT,DIRUT,DUOUT,SCHED,FILEIEN,MENUN,SOPT,ALLOF,ALLOF2,ALLNAM,LENGTH,FDA
- S PPG=1
- ;
- DISSO1 ;
- D HDR^PSNPARM
- DISSOS ;
- W !,"Enter the name or partial name of the Scheduled Option that you wish to have",!,"paused during the processing."
- K ^TMP("PSNPPSNR",$J),PPSN
- S (I,II,III,ICNT,X)=0,ICNT=0
- F S X=$O(^PS(57.23,1,3,"B",X)) Q:'$G(X) F S I=$O(^PS(57.23,1,3,"B",X,I)) Q:I="" D
- .S ^TMP("PSNPPSNR",$J,X)=I
- .S ICNT=ICNT+1,SOPT="",SOPT=$$GET1^DIQ(19.2,X,.01,"E") S:SOPT'="" PPSN(SOPT,ICNT)=I
- W:ICNT>0 !!?3,"PPS-N Scheduled Options defined to mark 'out of order':"
- F S I=$O(PPSN(I)) Q:I="" W !?8,I I $Y>20 R !,"Enter to continue...",X:120 W @IOF
- I $D(PPSN(2)) S I="" F S I=$O(PPSN(I)) Q:I="" W !," "_PPSN(I)
- R !!,"Scheduled Options: ",Y:120
- I $G(Y)=""!(Y=-1)!($G(DTOUT))!($G(DIRUT))!($G(DUOUT)) S PPG="" Q
- I Y="?" W @IOF,!!,"Enter the Scheduled Option that you wish to have paused during the",!,"processing of the update file or '??' for more help. ",! G DISSOS
- I Y="??" W @IOF D SHELP R !,"Enter to continue...",X:120 G DISSO1
- ;
- ;set all beginning with a prefix
- I Y["*" S ALLOF=$P(Y,"*"),LENGTH=$L(ALLOF) D G DISSO1
- .F S III=$O(^DIC(19.2,"B",III)) Q:III="" S IV="" F S IV=$O(^DIC(19.2,"B",III,IV)) Q:IV="" D
- ..S ALLNAM=$$GET1^DIQ(19.2,IV,.01,"E")
- ..Q:ALLNAM=""
- ..S ALLOF2=$E(ALLNAM,1,LENGTH)
- ..I ALLOF=ALLOF2 D
- ...Q:$D(^PS(57.23,1,3,"B",IV))
- ...S DIC="^PS(57.23,1,3,",DA(1)=1
- ...S FDA(57.24,"+1,1,",.01)=IV
- ...D UPDATE^DIE("","FDA","","ERROR")
- ;
- ;delete all beginning with a prefix
- I Y["@" S ALLOF=$P(Y,"@"),LENGTH=$L(ALLOF) D G DISSO1
- .K DIR S DIR("?")="Please enter Y or N.",DIR("B")="NO"
- .S DIR("A")="Are you sure that you want to delete ALL items starting with "_ALLOF,DIR(0)="Y"
- .D ^DIR
- .Q:'$G(Y)
- .F S III=$O(^PS(57.23,1,3,"B",III)) Q:III="" S IV="",IV=$O(^PS(57.23,1,3,"B",III,IV)) D
- ..S ALLNAM=$$GET1^DIQ(19.2,III,.01,"E")
- ..I ALLNAM'="" D
- ...S ALLOF2="",ALLOF2=$E(ALLNAM,1,LENGTH)
- ...Q:ALLOF'=ALLOF2
- ...K DIK,DIC S (DIK,DIC)="^PS(57.23,1,3,"
- ...S DA(1)=1,DA=IV,DR=".01///@" D ^DIK K DIR
- ;
- DISSO2 ;
- K DIC S DIC="^DIC(19.2,",DIC(0)="EQMZ",X=Y D ^DIC
- I ($G(DTOUT))!($G(DIRUT))!($G(DUOUT)) S PPG="" G DISSO1
- I 'Y!(Y=-1) W !!,"Selection not found.",! R !,"Enter to continue...",X:120 G DISSO1
- S (SCHED,FILEIEN,MENUN)="",SCHED=$P(Y,"^")
- I $D(^TMP("PSNPPSNR",$J,SCHED)) S FILEIEN=^TMP("PSNPPSNR",$J,SCHED),MENUN=$$GET1^DIQ(19,SCHED,.01,"E")
- G DISSO1:'Y!(Y=-1)!($G(DTOUT))!($G(DIRUT))!($G(DUOUT))
- ;
- DISSO3 ;
- I $D(SCHED),$D(^TMP("PSNPPSNR",$J,SCHED)) D Q
- .K DIR S DIR("?")="Please enter Y or N.",DIR("B")="NO",DIR("A")="Do you want to delete it from the PPS-N Control file"
- .S DIR(0)="Y"
- .D ^DIR
- .K DIK,DIC S (DIK,DIC)="^PS(57.23,1,3,",DA(1)=1
- .I $G(Y) S DA(1)=1,DA=FILEIEN,DR=".01///@" D ^DIK K DIR
- .Q:$G(DUOUT)!($G(DIRUT))!($G(DTOUT))!('$G(Y))
- S FDA(57.24,"+1,1,",.01)=SCHED
- D UPDATE^DIE("","FDA","","ERROR")
- Q
- ;
- DISMO ;
- S PPG=1
- N DIC,DIK,DR,DIR,DA,I,II,III,IV,ICNT,X,Y,DIE,DTOUT,DIRUT,DUOUT,SCHED,FILEIEN,MENUN,SOPT,ALLOF,ALLOF2,ALLNAM,LENGTH,FDA
- DISMO1 ;
- D HDR^PSNPARM
- DISMOS ;
- W !,"Enter the name or partial menu name of the menu that you wish to have paused",!,"during the processing."
- K ^TMP("PSNPPSNR",$J),PPSN
- S (I,II,III,ICNT,X)=0,ICNT=0
- F S X=$O(^PS(57.23,1,3.1,"B",X)) Q:'$G(X) F S I=$O(^PS(57.23,1,3.1,"B",X,I)) Q:I="" D
- .S ^TMP("PSNPPSNR",$J,X)=I
- .S ICNT=ICNT+1,SOPT="",SOPT=$$GET1^DIQ(19,X,.01,"E") S:SOPT'="" PPSN(SOPT,ICNT)=I
- W:ICNT>0 !!?3,"PPS-N Menu Options defined to mark 'out of order':"
- F S I=$O(PPSN(I)) Q:I="" W !?8,I I $Y>20 R !,"Enter to continue...",X:120 W @IOF
- I $D(PPSN(2)) S I="" F S I=$O(PPSN(I)) Q:I="" W !," "_PPSN(I)
- R !!,"Menu Option: ",Y:120
- I $G(Y)=""!(Y=-1)!($G(DTOUT))!($G(DIRUT))!($G(DUOUT)) S PPG="" Q
- I Y="?" W !!,"Enter the Menu Option that you wish to have paused during the processing of the update file or '??' for more help. ",! G DISMOS
- I Y="??" W @IOF D SHELP R !,"Enter to continue...",X:120 G DISMO1
- ;
- ;set all beginning with a prefix
- I Y["*" S ALLOF=$P(Y,"*"),LENGTH=$L(ALLOF) D G DISMO1
- .F S III=$O(^DIC(19,"B",III)) Q:III="" S IV="" F S IV=$O(^DIC(19,"B",III,IV)) Q:IV="" D
- ..S ALLNAM=$$GET1^DIQ(19,IV,.01,"E")
- ..Q:ALLNAM=""
- ..S ALLOF2=$E(ALLNAM,1,LENGTH)
- ..I ALLOF=ALLOF2 D
- ...Q:$D(^PS(57.23,1,3.1,"B",IV))
- ...S DIC="^PS(57.23,1,3.1,",DA(1)=1
- ...S FDA(57.2331,"+1,1,",.01)=IV
- ...D UPDATE^DIE("","FDA","","ERROR")
- ;
- ;delete all beginning with a prefix
- I Y["@" S ALLOF=$P(Y,"@"),LENGTH=$L(ALLOF) D G DISMO1
- .K DIR S DIR("?")="Please enter Y or N.",DIR("B")="NO",DIR("A")="Are you sure that you want to delete ALL items starting with "_ALLOF
- .S DIR(0)="Y"
- .D ^DIR
- .Q:'$G(Y)
- .F S III=$O(^PS(57.23,1,3.1,"B",III)) Q:III="" S IV="",IV=$O(^PS(57.23,1,3.1,"B",III,IV)) D
- ..S ALLNAM=$$GET1^DIQ(19,III,.01,"E")
- ..I ALLNAM'="" D
- ...S ALLOF2="",ALLOF2=$E(ALLNAM,1,LENGTH)
- ...Q:ALLOF'=ALLOF2
- ...K DIK,DIC S (DIK,DIC)="^PS(57.23,1,3.1,"
- ...S DA(1)=1,DA=IV,DR=".01///@" D ^DIK K DIR
- ;
- DISMO2 ;
- K DIC S DIC="^DIC(19,",DIC(0)="EQMZ",X=Y D ^DIC
- I ($G(DTOUT))!($G(DIRUT))!($G(DUOUT)) S PPG="" G DISMO1
- I 'Y!(Y=-1) W !!,"Selection not found.",! R !,"Enter to continue...",X:120 G DISMO1
- S (SCHED,FILEIEN,MENUN)="",SCHED=$P(Y,"^")
- I $D(^TMP("PSNPPSNR",$J,SCHED)) S FILEIEN=^TMP("PSNPPSNR",$J,SCHED),MENUN=$$GET1^DIQ(19,SCHED,.01,"E")
- G DISMO1:'Y!(Y=-1)!($G(DTOUT))!($G(DIRUT))!($G(DUOUT))
- ;
- DISMO3 ;
- I $D(SCHED),$D(^TMP("PSNPPSNR",$J,SCHED)) D Q
- .K DIR S DIR("?")="Please enter Y or N.",DIR("B")="NO",DIR("A")="Do you want to delete it from the PPS-N Control file"
- .S DIR(0)="Y"
- .D ^DIR
- .K DIK,DIC S (DIK,DIC)="^PS(57.23,1,3.1,",DA(1)=1
- .I $G(Y) S DA(1)=1,DA=FILEIEN,DR=".01///@" D ^DIK K DIR
- .Q:$G(DUOUT)!($G(DIRUT))!($G(DTOUT))!('$G(Y))
- S FDA(57.2331,"+1,1,",.01)=SCHED
- D UPDATE^DIE("","FDA","","ERROR")
- Q
- ;
- DISPR ;
- ;
- S PPG=1
- N DIC,DIK,DR,DIR,DA,I,II,III,IV,ICNT,X,Y,DIE,DTOUT,DIRUT,DUOUT,SCHED,FILEIEN,MENUN,SOPT,ALLOF,ALLOF2,ALLNAM,LENGTH,FDA
- DIPRO1 ;
- D HDR^PSNPARM
- DIPROS ;
- W !,"Enter the name or partial name of the protocol that you wish to have",!,"paused during the processing."
- K ^TMP("PSNPPSNR",$J),PPSN
- S (I,II,III,ICNT,X)=0,ICNT=0
- F S X=$O(^PS(57.23,1,3.2,"B",X)) Q:'$G(X) F S I=$O(^PS(57.23,1,3.2,"B",X,I)) Q:I="" D
- .S ^TMP("PSNPPSNR",$J,X)=I
- .S ICNT=ICNT+1,SOPT="",SOPT=$$GET1^DIQ(101,X,.01,"E") S:SOPT'="" PPSN(SOPT,ICNT)=I
- W:ICNT>0 !!?3,"PPS-N Protocols defined to mark 'out of order':"
- F S I=$O(PPSN(I)) Q:I="" W !?8,I I $Y>20 R !,"Enter to continue...",X:120 W @IOF
- I $D(PPSN(2)) S I="" F S I=$O(PPSN(I)) Q:I="" W !," "_PPSN(I)
- R !!,"Protocol: ",Y:120
- I $G(Y)=""!(Y=-1)!($G(DTOUT))!($G(DIRUT))!($G(DUOUT)) S PPG="" Q
- I Y="?" W !!,"Enter the Protocol that you wish to have paused during the processing of the update file or '??' for more help. ",! G DIPROS
- I Y="??" W @IOF D SHELP R !,"Enter to continue...",X:120 G DIPRO1
- ;
- ;set all beginning with a prefix
- I Y["*" S ALLOF=$P(Y,"*"),LENGTH=$L(ALLOF) D G DIPRO1
- .F S III=$O(^ORD(101,"B",III)) Q:III="" S IV="" F S IV=$O(^ORD(101,"B",III,IV)) Q:IV="" D
- ..S ALLNAM=$$GET1^DIQ(101,IV,.01,"E")
- ..Q:ALLNAM=""
- ..S ALLOF2=$E(ALLNAM,1,LENGTH)
- ..I ALLOF=ALLOF2 D
- ...Q:$D(^PS(57.23,1,3.2,"B",IV))
- ...S DIC="^PS(57.23,1,3.2,",DA(1)=1
- ...S FDA(57.2332,"+1,1,",.01)=IV
- ...D UPDATE^DIE("","FDA","","ERROR")
- ;
- ;delete all beginning with a prefix
- I Y["@" S ALLOF=$P(Y,"@"),LENGTH=$L(ALLOF) D G DIPRO1
- .K DIR S DIR("?")="Please enter Y or N.",DIR("B")="NO",DIR("A")="Are you sure that you want to delete ALL items starting with "_ALLOF
- .S DIR(0)="Y"
- .D ^DIR
- .Q:'$G(Y)
- .F S III=$O(^PS(57.23,1,3.2,"B",III)) Q:III="" S IV="",IV=$O(^PS(57.23,1,3.2,"B",III,IV)) D
- ..S ALLNAM=$$GET1^DIQ(101,III,.01,"E")
- ..I ALLNAM'="" D
- ...S ALLOF2="",ALLOF2=$E(ALLNAM,1,LENGTH)
- ...Q:ALLOF'=ALLOF2
- ...K DIK,DIC S (DIK,DIC)="^PS(57.23,1,3.2,"
- ...S DA(1)=1,DA=IV,DR=".01///@" D ^DIK K DIR
- ;
- ;
- DIPRO2 ;
- K DIC S DIC="^ORD(101,",DIC(0)="EQMZ",X=Y D ^DIC
- I ($G(DTOUT))!($G(DIRUT))!($G(DUOUT)) S PPG="" G DIPRO1
- I 'Y!(Y=-1) W !!,"Selection not found.",! R !,"Enter to continue...",X:120 G DIPRO1
- S (SCHED,FILEIEN,MENUN)="",SCHED=$P(Y,"^")
- I $D(^TMP("PSNPPSNR",$J,SCHED)) S FILEIEN=^TMP("PSNPPSNR",$J,SCHED),MENUN=$$GET1^DIQ(101,SCHED,.01,"E")
- G DIPRO1:'Y!(Y=-1)!($G(DTOUT))!($G(DIRUT))!($G(DUOUT))
- ;
- DIPRO3 ;
- I $D(SCHED),$D(^TMP("PSNPPSNR",$J,SCHED)) D Q
- .K DIR S DIR("?")="Please enter Y or N.",DIR("B")="NO"
- .S DIR("A")="Do you want to delete it from the PPS-N Control file",DIR(0)="Y"
- .D ^DIR
- .K DIK,DIC S (DIK,DIC)="^PS(57.23,1,3.2,",DA(1)=1
- .I $G(Y) S DA(1)=1,DA=FILEIEN,DR=".01///@" D ^DIK K DIR
- .Q:$G(DUOUT)!($G(DIRUT))!($G(DTOUT))!('$G(Y))
- S FDA(57.2332,"+1,1,",.01)=SCHED
- D UPDATE^DIE("","FDA","","ERROR")
- G DISPR
- Q
- ;
- SHELP ;
- W !,"You are building a list of options and/or protocols to be marked 'Out"
- W !,"Of Order'. You may enter them in several different ways:"
- W !,"You may simply enter an option or protocol name,"
- W !," or NAM for a listing all that begin with the characters 'NAM'"
- W !," or ^ to quit and exit the program,"
- W !," or ? to see a brief help prompt,"
- W !," or ?? to see this help screen again,"
- W !," or ??? to see all entries"
- W !," or NAM* to select everything that begins with the characters 'NAM'"
- W !," or NAM@ remove item that begin with the characters 'NAM'"
- W !
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSNPPSNR 10583 printed Jan 18, 2025@03:25:49 Page 2
- PSNPPSNR ;HP/AF-CONF option continued ; 05 Mar 2014 1:20 PM
- +1 ;;4.0;NATIONAL DRUG FILE;**513**; 30 Oct 98;Build 53
- +2 ;External reference to ^ORD(101 supported by DBIA #872
- +3 ;External reference ^DIC(19.2 supported by DBIA #1472
- +4 ;Reference to ^DIC(19 supported by DBIA #2246
- +5 ;Reference to ^DIC(19.2 supported by DBIA #2910
- +6 ;Reference to ^ORD( supported by DBIA #872
- +7 ;
- +8 ;Mark Scheduled options, menu options, and protocol out of order.
- +9 ;Used by UPDT - Begin update of NDF data from PPS-N option during install of PPS-N/NDF Update file.
- DISOPTS ;
- +1 NEW DIRUT,DUOUT,DIR,X,Y,PPG,DA,DIC,DIE,DR,DUOUT,DIRUT,PPSN
- +2 SET (Y,X,PPG)=""
- SET DIR(0)="Y"
- SET DIR("?")="Please enter Y or N."
- +3 SET DIR("A")="Do you want to DISABLE Scheduled Options, Menu Options and Protocols"
- +4 SET DIR("B")="YES"
- +5 DO ^DIR
- +6 if Y="^"!("Nn"[Y)!('Y)!$GET(DIRUT)!$GET(DTOUT)
- QUIT
- +7 FOR
- DO DISSO
- if PPG=""!$GET(DIRUT)!$GET(DTOUT)
- QUIT
- +8 FOR
- DO DISMO
- if PPG=""!$GET(DIRUT)!$GET(DTOUT)
- QUIT
- +9 FOR
- DO DISPR
- if PPG=""!$GET(DIRUT)!$GET(DTOUT)
- QUIT
- +10 KILL ^TMP("PSNPPSNR",$JOB)
- +11 QUIT
- +12 ;
- DISSO ;
- +1 NEW DIC,DIK,DR,DIR,DA,I,II,III,IV,ICNT,X,Y,DIE,DTOUT,DIRUT,DUOUT,SCHED,FILEIEN,MENUN,SOPT,ALLOF,ALLOF2,ALLNAM,LENGTH,FDA
- +2 SET PPG=1
- +3 ;
- DISSO1 ;
- +1 DO HDR^PSNPARM
- DISSOS ;
- +1 WRITE !,"Enter the name or partial name of the Scheduled Option that you wish to have",!,"paused during the processing."
- +2 KILL ^TMP("PSNPPSNR",$JOB),PPSN
- +3 SET (I,II,III,ICNT,X)=0
- SET ICNT=0
- +4 FOR
- SET X=$ORDER(^PS(57.23,1,3,"B",X))
- if '$GET(X)
- QUIT
- FOR
- SET I=$ORDER(^PS(57.23,1,3,"B",X,I))
- if I=""
- QUIT
- Begin DoDot:1
- +5 SET ^TMP("PSNPPSNR",$JOB,X)=I
- +6 SET ICNT=ICNT+1
- SET SOPT=""
- SET SOPT=$$GET1^DIQ(19.2,X,.01,"E")
- if SOPT'=""
- SET PPSN(SOPT,ICNT)=I
- End DoDot:1
- +7 if ICNT>0
- WRITE !!?3,"PPS-N Scheduled Options defined to mark 'out of order':"
- +8 FOR
- SET I=$ORDER(PPSN(I))
- if I=""
- QUIT
- WRITE !?8,I
- IF $Y>20
- READ !,"Enter to continue...",X:120
- WRITE @IOF
- +9 IF $DATA(PPSN(2))
- SET I=""
- FOR
- SET I=$ORDER(PPSN(I))
- if I=""
- QUIT
- WRITE !," "_PPSN(I)
- +10 READ !!,"Scheduled Options: ",Y:120
- +11 IF $GET(Y)=""!(Y=-1)!($GET(DTOUT))!($GET(DIRUT))!($GET(DUOUT))
- SET PPG=""
- QUIT
- +12 IF Y="?"
- WRITE @IOF,!!,"Enter the Scheduled Option that you wish to have paused during the",!,"processing of the update file or '??' for more help. ",!
- GOTO DISSOS
- +13 IF Y="??"
- WRITE @IOF
- DO SHELP
- READ !,"Enter to continue...",X:120
- GOTO DISSO1
- +14 ;
- +15 ;set all beginning with a prefix
- +16 IF Y["*"
- SET ALLOF=$PIECE(Y,"*")
- SET LENGTH=$LENGTH(ALLOF)
- Begin DoDot:1
- +17 FOR
- SET III=$ORDER(^DIC(19.2,"B",III))
- if III=""
- QUIT
- SET IV=""
- FOR
- SET IV=$ORDER(^DIC(19.2,"B",III,IV))
- if IV=""
- QUIT
- Begin DoDot:2
- +18 SET ALLNAM=$$GET1^DIQ(19.2,IV,.01,"E")
- +19 if ALLNAM=""
- QUIT
- +20 SET ALLOF2=$EXTRACT(ALLNAM,1,LENGTH)
- +21 IF ALLOF=ALLOF2
- Begin DoDot:3
- +22 if $DATA(^PS(57.23,1,3,"B",IV))
- QUIT
- +23 SET DIC="^PS(57.23,1,3,"
- SET DA(1)=1
- +24 SET FDA(57.24,"+1,1,",.01)=IV
- +25 DO UPDATE^DIE("","FDA","","ERROR")
- End DoDot:3
- End DoDot:2
- End DoDot:1
- GOTO DISSO1
- +26 ;
- +27 ;delete all beginning with a prefix
- +28 IF Y["@"
- SET ALLOF=$PIECE(Y,"@")
- SET LENGTH=$LENGTH(ALLOF)
- Begin DoDot:1
- +29 KILL DIR
- SET DIR("?")="Please enter Y or N."
- SET DIR("B")="NO"
- +30 SET DIR("A")="Are you sure that you want to delete ALL items starting with "_ALLOF
- SET DIR(0)="Y"
- +31 DO ^DIR
- +32 if '$GET(Y)
- QUIT
- +33 FOR
- SET III=$ORDER(^PS(57.23,1,3,"B",III))
- if III=""
- QUIT
- SET IV=""
- SET IV=$ORDER(^PS(57.23,1,3,"B",III,IV))
- Begin DoDot:2
- +34 SET ALLNAM=$$GET1^DIQ(19.2,III,.01,"E")
- +35 IF ALLNAM'=""
- Begin DoDot:3
- +36 SET ALLOF2=""
- SET ALLOF2=$EXTRACT(ALLNAM,1,LENGTH)
- +37 if ALLOF'=ALLOF2
- QUIT
- +38 KILL DIK,DIC
- SET (DIK,DIC)="^PS(57.23,1,3,"
- +39 SET DA(1)=1
- SET DA=IV
- SET DR=".01///@"
- DO ^DIK
- KILL DIR
- End DoDot:3
- End DoDot:2
- End DoDot:1
- GOTO DISSO1
- +40 ;
- DISSO2 ;
- +1 KILL DIC
- SET DIC="^DIC(19.2,"
- SET DIC(0)="EQMZ"
- SET X=Y
- DO ^DIC
- +2 IF ($GET(DTOUT))!($GET(DIRUT))!($GET(DUOUT))
- SET PPG=""
- GOTO DISSO1
- +3 IF 'Y!(Y=-1)
- WRITE !!,"Selection not found.",!
- READ !,"Enter to continue...",X:120
- GOTO DISSO1
- +4 SET (SCHED,FILEIEN,MENUN)=""
- SET SCHED=$PIECE(Y,"^")
- +5 IF $DATA(^TMP("PSNPPSNR",$JOB,SCHED))
- SET FILEIEN=^TMP("PSNPPSNR",$JOB,SCHED)
- SET MENUN=$$GET1^DIQ(19,SCHED,.01,"E")
- +6 if 'Y!(Y=-1)!($GET(DTOUT))!($GET(DIRUT))!($GET(DUOUT))
- GOTO DISSO1
- +7 ;
- DISSO3 ;
- +1 IF $DATA(SCHED)
- IF $DATA(^TMP("PSNPPSNR",$JOB,SCHED))
- Begin DoDot:1
- +2 KILL DIR
- SET DIR("?")="Please enter Y or N."
- SET DIR("B")="NO"
- SET DIR("A")="Do you want to delete it from the PPS-N Control file"
- +3 SET DIR(0)="Y"
- +4 DO ^DIR
- +5 KILL DIK,DIC
- SET (DIK,DIC)="^PS(57.23,1,3,"
- SET DA(1)=1
- +6 IF $GET(Y)
- SET DA(1)=1
- SET DA=FILEIEN
- SET DR=".01///@"
- DO ^DIK
- KILL DIR
- +7 if $GET(DUOUT)!($GET(DIRUT))!($GET(DTOUT))!('$GET(Y))
- QUIT
- End DoDot:1
- QUIT
- +8 SET FDA(57.24,"+1,1,",.01)=SCHED
- +9 DO UPDATE^DIE("","FDA","","ERROR")
- +10 QUIT
- +11 ;
- DISMO ;
- +1 SET PPG=1
- +2 NEW DIC,DIK,DR,DIR,DA,I,II,III,IV,ICNT,X,Y,DIE,DTOUT,DIRUT,DUOUT,SCHED,FILEIEN,MENUN,SOPT,ALLOF,ALLOF2,ALLNAM,LENGTH,FDA
- DISMO1 ;
- +1 DO HDR^PSNPARM
- DISMOS ;
- +1 WRITE !,"Enter the name or partial menu name of the menu that you wish to have paused",!,"during the processing."
- +2 KILL ^TMP("PSNPPSNR",$JOB),PPSN
- +3 SET (I,II,III,ICNT,X)=0
- SET ICNT=0
- +4 FOR
- SET X=$ORDER(^PS(57.23,1,3.1,"B",X))
- if '$GET(X)
- QUIT
- FOR
- SET I=$ORDER(^PS(57.23,1,3.1,"B",X,I))
- if I=""
- QUIT
- Begin DoDot:1
- +5 SET ^TMP("PSNPPSNR",$JOB,X)=I
- +6 SET ICNT=ICNT+1
- SET SOPT=""
- SET SOPT=$$GET1^DIQ(19,X,.01,"E")
- if SOPT'=""
- SET PPSN(SOPT,ICNT)=I
- End DoDot:1
- +7 if ICNT>0
- WRITE !!?3,"PPS-N Menu Options defined to mark 'out of order':"
- +8 FOR
- SET I=$ORDER(PPSN(I))
- if I=""
- QUIT
- WRITE !?8,I
- IF $Y>20
- READ !,"Enter to continue...",X:120
- WRITE @IOF
- +9 IF $DATA(PPSN(2))
- SET I=""
- FOR
- SET I=$ORDER(PPSN(I))
- if I=""
- QUIT
- WRITE !," "_PPSN(I)
- +10 READ !!,"Menu Option: ",Y:120
- +11 IF $GET(Y)=""!(Y=-1)!($GET(DTOUT))!($GET(DIRUT))!($GET(DUOUT))
- SET PPG=""
- QUIT
- +12 IF Y="?"
- WRITE !!,"Enter the Menu Option that you wish to have paused during the processing of the update file or '??' for more help. ",!
- GOTO DISMOS
- +13 IF Y="??"
- WRITE @IOF
- DO SHELP
- READ !,"Enter to continue...",X:120
- GOTO DISMO1
- +14 ;
- +15 ;set all beginning with a prefix
- +16 IF Y["*"
- SET ALLOF=$PIECE(Y,"*")
- SET LENGTH=$LENGTH(ALLOF)
- Begin DoDot:1
- +17 FOR
- SET III=$ORDER(^DIC(19,"B",III))
- if III=""
- QUIT
- SET IV=""
- FOR
- SET IV=$ORDER(^DIC(19,"B",III,IV))
- if IV=""
- QUIT
- Begin DoDot:2
- +18 SET ALLNAM=$$GET1^DIQ(19,IV,.01,"E")
- +19 if ALLNAM=""
- QUIT
- +20 SET ALLOF2=$EXTRACT(ALLNAM,1,LENGTH)
- +21 IF ALLOF=ALLOF2
- Begin DoDot:3
- +22 if $DATA(^PS(57.23,1,3.1,"B",IV))
- QUIT
- +23 SET DIC="^PS(57.23,1,3.1,"
- SET DA(1)=1
- +24 SET FDA(57.2331,"+1,1,",.01)=IV
- +25 DO UPDATE^DIE("","FDA","","ERROR")
- End DoDot:3
- End DoDot:2
- End DoDot:1
- GOTO DISMO1
- +26 ;
- +27 ;delete all beginning with a prefix
- +28 IF Y["@"
- SET ALLOF=$PIECE(Y,"@")
- SET LENGTH=$LENGTH(ALLOF)
- Begin DoDot:1
- +29 KILL DIR
- SET DIR("?")="Please enter Y or N."
- SET DIR("B")="NO"
- SET DIR("A")="Are you sure that you want to delete ALL items starting with "_ALLOF
- +30 SET DIR(0)="Y"
- +31 DO ^DIR
- +32 if '$GET(Y)
- QUIT
- +33 FOR
- SET III=$ORDER(^PS(57.23,1,3.1,"B",III))
- if III=""
- QUIT
- SET IV=""
- SET IV=$ORDER(^PS(57.23,1,3.1,"B",III,IV))
- Begin DoDot:2
- +34 SET ALLNAM=$$GET1^DIQ(19,III,.01,"E")
- +35 IF ALLNAM'=""
- Begin DoDot:3
- +36 SET ALLOF2=""
- SET ALLOF2=$EXTRACT(ALLNAM,1,LENGTH)
- +37 if ALLOF'=ALLOF2
- QUIT
- +38 KILL DIK,DIC
- SET (DIK,DIC)="^PS(57.23,1,3.1,"
- +39 SET DA(1)=1
- SET DA=IV
- SET DR=".01///@"
- DO ^DIK
- KILL DIR
- End DoDot:3
- End DoDot:2
- End DoDot:1
- GOTO DISMO1
- +40 ;
- DISMO2 ;
- +1 KILL DIC
- SET DIC="^DIC(19,"
- SET DIC(0)="EQMZ"
- SET X=Y
- DO ^DIC
- +2 IF ($GET(DTOUT))!($GET(DIRUT))!($GET(DUOUT))
- SET PPG=""
- GOTO DISMO1
- +3 IF 'Y!(Y=-1)
- WRITE !!,"Selection not found.",!
- READ !,"Enter to continue...",X:120
- GOTO DISMO1
- +4 SET (SCHED,FILEIEN,MENUN)=""
- SET SCHED=$PIECE(Y,"^")
- +5 IF $DATA(^TMP("PSNPPSNR",$JOB,SCHED))
- SET FILEIEN=^TMP("PSNPPSNR",$JOB,SCHED)
- SET MENUN=$$GET1^DIQ(19,SCHED,.01,"E")
- +6 if 'Y!(Y=-1)!($GET(DTOUT))!($GET(DIRUT))!($GET(DUOUT))
- GOTO DISMO1
- +7 ;
- DISMO3 ;
- +1 IF $DATA(SCHED)
- IF $DATA(^TMP("PSNPPSNR",$JOB,SCHED))
- Begin DoDot:1
- +2 KILL DIR
- SET DIR("?")="Please enter Y or N."
- SET DIR("B")="NO"
- SET DIR("A")="Do you want to delete it from the PPS-N Control file"
- +3 SET DIR(0)="Y"
- +4 DO ^DIR
- +5 KILL DIK,DIC
- SET (DIK,DIC)="^PS(57.23,1,3.1,"
- SET DA(1)=1
- +6 IF $GET(Y)
- SET DA(1)=1
- SET DA=FILEIEN
- SET DR=".01///@"
- DO ^DIK
- KILL DIR
- +7 if $GET(DUOUT)!($GET(DIRUT))!($GET(DTOUT))!('$GET(Y))
- QUIT
- End DoDot:1
- QUIT
- +8 SET FDA(57.2331,"+1,1,",.01)=SCHED
- +9 DO UPDATE^DIE("","FDA","","ERROR")
- +10 QUIT
- +11 ;
- DISPR ;
- +1 ;
- +2 SET PPG=1
- +3 NEW DIC,DIK,DR,DIR,DA,I,II,III,IV,ICNT,X,Y,DIE,DTOUT,DIRUT,DUOUT,SCHED,FILEIEN,MENUN,SOPT,ALLOF,ALLOF2,ALLNAM,LENGTH,FDA
- DIPRO1 ;
- +1 DO HDR^PSNPARM
- DIPROS ;
- +1 WRITE !,"Enter the name or partial name of the protocol that you wish to have",!,"paused during the processing."
- +2 KILL ^TMP("PSNPPSNR",$JOB),PPSN
- +3 SET (I,II,III,ICNT,X)=0
- SET ICNT=0
- +4 FOR
- SET X=$ORDER(^PS(57.23,1,3.2,"B",X))
- if '$GET(X)
- QUIT
- FOR
- SET I=$ORDER(^PS(57.23,1,3.2,"B",X,I))
- if I=""
- QUIT
- Begin DoDot:1
- +5 SET ^TMP("PSNPPSNR",$JOB,X)=I
- +6 SET ICNT=ICNT+1
- SET SOPT=""
- SET SOPT=$$GET1^DIQ(101,X,.01,"E")
- if SOPT'=""
- SET PPSN(SOPT,ICNT)=I
- End DoDot:1
- +7 if ICNT>0
- WRITE !!?3,"PPS-N Protocols defined to mark 'out of order':"
- +8 FOR
- SET I=$ORDER(PPSN(I))
- if I=""
- QUIT
- WRITE !?8,I
- IF $Y>20
- READ !,"Enter to continue...",X:120
- WRITE @IOF
- +9 IF $DATA(PPSN(2))
- SET I=""
- FOR
- SET I=$ORDER(PPSN(I))
- if I=""
- QUIT
- WRITE !," "_PPSN(I)
- +10 READ !!,"Protocol: ",Y:120
- +11 IF $GET(Y)=""!(Y=-1)!($GET(DTOUT))!($GET(DIRUT))!($GET(DUOUT))
- SET PPG=""
- QUIT
- +12 IF Y="?"
- WRITE !!,"Enter the Protocol that you wish to have paused during the processing of the update file or '??' for more help. ",!
- GOTO DIPROS
- +13 IF Y="??"
- WRITE @IOF
- DO SHELP
- READ !,"Enter to continue...",X:120
- GOTO DIPRO1
- +14 ;
- +15 ;set all beginning with a prefix
- +16 IF Y["*"
- SET ALLOF=$PIECE(Y,"*")
- SET LENGTH=$LENGTH(ALLOF)
- Begin DoDot:1
- +17 FOR
- SET III=$ORDER(^ORD(101,"B",III))
- if III=""
- QUIT
- SET IV=""
- FOR
- SET IV=$ORDER(^ORD(101,"B",III,IV))
- if IV=""
- QUIT
- Begin DoDot:2
- +18 SET ALLNAM=$$GET1^DIQ(101,IV,.01,"E")
- +19 if ALLNAM=""
- QUIT
- +20 SET ALLOF2=$EXTRACT(ALLNAM,1,LENGTH)
- +21 IF ALLOF=ALLOF2
- Begin DoDot:3
- +22 if $DATA(^PS(57.23,1,3.2,"B",IV))
- QUIT
- +23 SET DIC="^PS(57.23,1,3.2,"
- SET DA(1)=1
- +24 SET FDA(57.2332,"+1,1,",.01)=IV
- +25 DO UPDATE^DIE("","FDA","","ERROR")
- End DoDot:3
- End DoDot:2
- End DoDot:1
- GOTO DIPRO1
- +26 ;
- +27 ;delete all beginning with a prefix
- +28 IF Y["@"
- SET ALLOF=$PIECE(Y,"@")
- SET LENGTH=$LENGTH(ALLOF)
- Begin DoDot:1
- +29 KILL DIR
- SET DIR("?")="Please enter Y or N."
- SET DIR("B")="NO"
- SET DIR("A")="Are you sure that you want to delete ALL items starting with "_ALLOF
- +30 SET DIR(0)="Y"
- +31 DO ^DIR
- +32 if '$GET(Y)
- QUIT
- +33 FOR
- SET III=$ORDER(^PS(57.23,1,3.2,"B",III))
- if III=""
- QUIT
- SET IV=""
- SET IV=$ORDER(^PS(57.23,1,3.2,"B",III,IV))
- Begin DoDot:2
- +34 SET ALLNAM=$$GET1^DIQ(101,III,.01,"E")
- +35 IF ALLNAM'=""
- Begin DoDot:3
- +36 SET ALLOF2=""
- SET ALLOF2=$EXTRACT(ALLNAM,1,LENGTH)
- +37 if ALLOF'=ALLOF2
- QUIT
- +38 KILL DIK,DIC
- SET (DIK,DIC)="^PS(57.23,1,3.2,"
- +39 SET DA(1)=1
- SET DA=IV
- SET DR=".01///@"
- DO ^DIK
- KILL DIR
- End DoDot:3
- End DoDot:2
- End DoDot:1
- GOTO DIPRO1
- +40 ;
- +41 ;
- DIPRO2 ;
- +1 KILL DIC
- SET DIC="^ORD(101,"
- SET DIC(0)="EQMZ"
- SET X=Y
- DO ^DIC
- +2 IF ($GET(DTOUT))!($GET(DIRUT))!($GET(DUOUT))
- SET PPG=""
- GOTO DIPRO1
- +3 IF 'Y!(Y=-1)
- WRITE !!,"Selection not found.",!
- READ !,"Enter to continue...",X:120
- GOTO DIPRO1
- +4 SET (SCHED,FILEIEN,MENUN)=""
- SET SCHED=$PIECE(Y,"^")
- +5 IF $DATA(^TMP("PSNPPSNR",$JOB,SCHED))
- SET FILEIEN=^TMP("PSNPPSNR",$JOB,SCHED)
- SET MENUN=$$GET1^DIQ(101,SCHED,.01,"E")
- +6 if 'Y!(Y=-1)!($GET(DTOUT))!($GET(DIRUT))!($GET(DUOUT))
- GOTO DIPRO1
- +7 ;
- DIPRO3 ;
- +1 IF $DATA(SCHED)
- IF $DATA(^TMP("PSNPPSNR",$JOB,SCHED))
- Begin DoDot:1
- +2 KILL DIR
- SET DIR("?")="Please enter Y or N."
- SET DIR("B")="NO"
- +3 SET DIR("A")="Do you want to delete it from the PPS-N Control file"
- SET DIR(0)="Y"
- +4 DO ^DIR
- +5 KILL DIK,DIC
- SET (DIK,DIC)="^PS(57.23,1,3.2,"
- SET DA(1)=1
- +6 IF $GET(Y)
- SET DA(1)=1
- SET DA=FILEIEN
- SET DR=".01///@"
- DO ^DIK
- KILL DIR
- +7 if $GET(DUOUT)!($GET(DIRUT))!($GET(DTOUT))!('$GET(Y))
- QUIT
- End DoDot:1
- QUIT
- +8 SET FDA(57.2332,"+1,1,",.01)=SCHED
- +9 DO UPDATE^DIE("","FDA","","ERROR")
- +10 GOTO DISPR
- +11 QUIT
- +12 ;
- SHELP ;
- +1 WRITE !,"You are building a list of options and/or protocols to be marked 'Out"
- +2 WRITE !,"Of Order'. You may enter them in several different ways:"
- +3 WRITE !,"You may simply enter an option or protocol name,"
- +4 WRITE !," or NAM for a listing all that begin with the characters 'NAM'"
- +5 WRITE !," or ^ to quit and exit the program,"
- +6 WRITE !," or ? to see a brief help prompt,"
- +7 WRITE !," or ?? to see this help screen again,"
- +8 WRITE !," or ??? to see all entries"
- +9 WRITE !," or NAM* to select everything that begins with the characters 'NAM'"
- +10 WRITE !," or NAM@ remove item that begin with the characters 'NAM'"
- +11 WRITE !
- +12 QUIT