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 Sep 23, 2025@20:00: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
