Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSNPPSNR

PSNPPSNR.m

Go to the documentation of this file.
  1. PSNPPSNR ;HP/AF-CONF option continued ; 05 Mar 2014 1:20 PM
  1. ;;4.0;NATIONAL DRUG FILE;**513**; 30 Oct 98;Build 53
  1. ;External reference to ^ORD(101 supported by DBIA #872
  1. ;External reference ^DIC(19.2 supported by DBIA #1472
  1. ;Reference to ^DIC(19 supported by DBIA #2246
  1. ;Reference to ^DIC(19.2 supported by DBIA #2910
  1. ;Reference to ^ORD( supported by DBIA #872
  1. ;
  1. ;Mark Scheduled options, menu options, and protocol out of order.
  1. ;Used by UPDT - Begin update of NDF data from PPS-N option during install of PPS-N/NDF Update file.
  1. DISOPTS ;
  1. N DIRUT,DUOUT,DIR,X,Y,PPG,DA,DIC,DIE,DR,DUOUT,DIRUT,PPSN
  1. S (Y,X,PPG)="",DIR(0)="Y",DIR("?")="Please enter Y or N."
  1. S DIR("A")="Do you want to DISABLE Scheduled Options, Menu Options and Protocols"
  1. S DIR("B")="YES"
  1. D ^DIR
  1. Q:Y="^"!("Nn"[Y)!('Y)!$G(DIRUT)!$G(DTOUT)
  1. F D DISSO Q:PPG=""!$G(DIRUT)!$G(DTOUT)
  1. F D DISMO Q:PPG=""!$G(DIRUT)!$G(DTOUT)
  1. F D DISPR Q:PPG=""!$G(DIRUT)!$G(DTOUT)
  1. K ^TMP("PSNPPSNR",$J)
  1. Q
  1. ;
  1. DISSO ;
  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
  1. S PPG=1
  1. ;
  1. DISSO1 ;
  1. D HDR^PSNPARM
  1. DISSOS ;
  1. W !,"Enter the name or partial name of the Scheduled Option that you wish to have",!,"paused during the processing."
  1. K ^TMP("PSNPPSNR",$J),PPSN
  1. S (I,II,III,ICNT,X)=0,ICNT=0
  1. 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
  1. .S ^TMP("PSNPPSNR",$J,X)=I
  1. .S ICNT=ICNT+1,SOPT="",SOPT=$$GET1^DIQ(19.2,X,.01,"E") S:SOPT'="" PPSN(SOPT,ICNT)=I
  1. W:ICNT>0 !!?3,"PPS-N Scheduled Options defined to mark 'out of order':"
  1. F S I=$O(PPSN(I)) Q:I="" W !?8,I I $Y>20 R !,"Enter to continue...",X:120 W @IOF
  1. I $D(PPSN(2)) S I="" F S I=$O(PPSN(I)) Q:I="" W !," "_PPSN(I)
  1. R !!,"Scheduled Options: ",Y:120
  1. I $G(Y)=""!(Y=-1)!($G(DTOUT))!($G(DIRUT))!($G(DUOUT)) S PPG="" Q
  1. 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
  1. I Y="??" W @IOF D SHELP R !,"Enter to continue...",X:120 G DISSO1
  1. ;
  1. ;set all beginning with a prefix
  1. I Y["*" S ALLOF=$P(Y,"*"),LENGTH=$L(ALLOF) D G DISSO1
  1. .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
  1. ..S ALLNAM=$$GET1^DIQ(19.2,IV,.01,"E")
  1. ..Q:ALLNAM=""
  1. ..S ALLOF2=$E(ALLNAM,1,LENGTH)
  1. ..I ALLOF=ALLOF2 D
  1. ...Q:$D(^PS(57.23,1,3,"B",IV))
  1. ...S DIC="^PS(57.23,1,3,",DA(1)=1
  1. ...S FDA(57.24,"+1,1,",.01)=IV
  1. ...D UPDATE^DIE("","FDA","","ERROR")
  1. ;
  1. ;delete all beginning with a prefix
  1. I Y["@" S ALLOF=$P(Y,"@"),LENGTH=$L(ALLOF) D G DISSO1
  1. .K DIR S DIR("?")="Please enter Y or N.",DIR("B")="NO"
  1. .S DIR("A")="Are you sure that you want to delete ALL items starting with "_ALLOF,DIR(0)="Y"
  1. .D ^DIR
  1. .Q:'$G(Y)
  1. .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
  1. ..S ALLNAM=$$GET1^DIQ(19.2,III,.01,"E")
  1. ..I ALLNAM'="" D
  1. ...S ALLOF2="",ALLOF2=$E(ALLNAM,1,LENGTH)
  1. ...Q:ALLOF'=ALLOF2
  1. ...K DIK,DIC S (DIK,DIC)="^PS(57.23,1,3,"
  1. ...S DA(1)=1,DA=IV,DR=".01///@" D ^DIK K DIR
  1. ;
  1. DISSO2 ;
  1. K DIC S DIC="^DIC(19.2,",DIC(0)="EQMZ",X=Y D ^DIC
  1. I ($G(DTOUT))!($G(DIRUT))!($G(DUOUT)) S PPG="" G DISSO1
  1. I 'Y!(Y=-1) W !!,"Selection not found.",! R !,"Enter to continue...",X:120 G DISSO1
  1. S (SCHED,FILEIEN,MENUN)="",SCHED=$P(Y,"^")
  1. I $D(^TMP("PSNPPSNR",$J,SCHED)) S FILEIEN=^TMP("PSNPPSNR",$J,SCHED),MENUN=$$GET1^DIQ(19,SCHED,.01,"E")
  1. G DISSO1:'Y!(Y=-1)!($G(DTOUT))!($G(DIRUT))!($G(DUOUT))
  1. ;
  1. DISSO3 ;
  1. I $D(SCHED),$D(^TMP("PSNPPSNR",$J,SCHED)) D Q
  1. .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"
  1. .S DIR(0)="Y"
  1. .D ^DIR
  1. .K DIK,DIC S (DIK,DIC)="^PS(57.23,1,3,",DA(1)=1
  1. .I $G(Y) S DA(1)=1,DA=FILEIEN,DR=".01///@" D ^DIK K DIR
  1. .Q:$G(DUOUT)!($G(DIRUT))!($G(DTOUT))!('$G(Y))
  1. S FDA(57.24,"+1,1,",.01)=SCHED
  1. D UPDATE^DIE("","FDA","","ERROR")
  1. Q
  1. ;
  1. DISMO ;
  1. S PPG=1
  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
  1. DISMO1 ;
  1. D HDR^PSNPARM
  1. DISMOS ;
  1. W !,"Enter the name or partial menu name of the menu that you wish to have paused",!,"during the processing."
  1. K ^TMP("PSNPPSNR",$J),PPSN
  1. S (I,II,III,ICNT,X)=0,ICNT=0
  1. 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
  1. .S ^TMP("PSNPPSNR",$J,X)=I
  1. .S ICNT=ICNT+1,SOPT="",SOPT=$$GET1^DIQ(19,X,.01,"E") S:SOPT'="" PPSN(SOPT,ICNT)=I
  1. W:ICNT>0 !!?3,"PPS-N Menu Options defined to mark 'out of order':"
  1. F S I=$O(PPSN(I)) Q:I="" W !?8,I I $Y>20 R !,"Enter to continue...",X:120 W @IOF
  1. I $D(PPSN(2)) S I="" F S I=$O(PPSN(I)) Q:I="" W !," "_PPSN(I)
  1. R !!,"Menu Option: ",Y:120
  1. I $G(Y)=""!(Y=-1)!($G(DTOUT))!($G(DIRUT))!($G(DUOUT)) S PPG="" Q
  1. 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
  1. I Y="??" W @IOF D SHELP R !,"Enter to continue...",X:120 G DISMO1
  1. ;
  1. ;set all beginning with a prefix
  1. I Y["*" S ALLOF=$P(Y,"*"),LENGTH=$L(ALLOF) D G DISMO1
  1. .F S III=$O(^DIC(19,"B",III)) Q:III="" S IV="" F S IV=$O(^DIC(19,"B",III,IV)) Q:IV="" D
  1. ..S ALLNAM=$$GET1^DIQ(19,IV,.01,"E")
  1. ..Q:ALLNAM=""
  1. ..S ALLOF2=$E(ALLNAM,1,LENGTH)
  1. ..I ALLOF=ALLOF2 D
  1. ...Q:$D(^PS(57.23,1,3.1,"B",IV))
  1. ...S DIC="^PS(57.23,1,3.1,",DA(1)=1
  1. ...S FDA(57.2331,"+1,1,",.01)=IV
  1. ...D UPDATE^DIE("","FDA","","ERROR")
  1. ;
  1. ;delete all beginning with a prefix
  1. I Y["@" S ALLOF=$P(Y,"@"),LENGTH=$L(ALLOF) D G DISMO1
  1. .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
  1. .S DIR(0)="Y"
  1. .D ^DIR
  1. .Q:'$G(Y)
  1. .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
  1. ..S ALLNAM=$$GET1^DIQ(19,III,.01,"E")
  1. ..I ALLNAM'="" D
  1. ...S ALLOF2="",ALLOF2=$E(ALLNAM,1,LENGTH)
  1. ...Q:ALLOF'=ALLOF2
  1. ...K DIK,DIC S (DIK,DIC)="^PS(57.23,1,3.1,"
  1. ...S DA(1)=1,DA=IV,DR=".01///@" D ^DIK K DIR
  1. ;
  1. DISMO2 ;
  1. K DIC S DIC="^DIC(19,",DIC(0)="EQMZ",X=Y D ^DIC
  1. I ($G(DTOUT))!($G(DIRUT))!($G(DUOUT)) S PPG="" G DISMO1
  1. I 'Y!(Y=-1) W !!,"Selection not found.",! R !,"Enter to continue...",X:120 G DISMO1
  1. S (SCHED,FILEIEN,MENUN)="",SCHED=$P(Y,"^")
  1. I $D(^TMP("PSNPPSNR",$J,SCHED)) S FILEIEN=^TMP("PSNPPSNR",$J,SCHED),MENUN=$$GET1^DIQ(19,SCHED,.01,"E")
  1. G DISMO1:'Y!(Y=-1)!($G(DTOUT))!($G(DIRUT))!($G(DUOUT))
  1. ;
  1. DISMO3 ;
  1. I $D(SCHED),$D(^TMP("PSNPPSNR",$J,SCHED)) D Q
  1. .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"
  1. .S DIR(0)="Y"
  1. .D ^DIR
  1. .K DIK,DIC S (DIK,DIC)="^PS(57.23,1,3.1,",DA(1)=1
  1. .I $G(Y) S DA(1)=1,DA=FILEIEN,DR=".01///@" D ^DIK K DIR
  1. .Q:$G(DUOUT)!($G(DIRUT))!($G(DTOUT))!('$G(Y))
  1. S FDA(57.2331,"+1,1,",.01)=SCHED
  1. D UPDATE^DIE("","FDA","","ERROR")
  1. Q
  1. ;
  1. DISPR ;
  1. ;
  1. S PPG=1
  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
  1. DIPRO1 ;
  1. D HDR^PSNPARM
  1. DIPROS ;
  1. W !,"Enter the name or partial name of the protocol that you wish to have",!,"paused during the processing."
  1. K ^TMP("PSNPPSNR",$J),PPSN
  1. S (I,II,III,ICNT,X)=0,ICNT=0
  1. 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
  1. .S ^TMP("PSNPPSNR",$J,X)=I
  1. .S ICNT=ICNT+1,SOPT="",SOPT=$$GET1^DIQ(101,X,.01,"E") S:SOPT'="" PPSN(SOPT,ICNT)=I
  1. W:ICNT>0 !!?3,"PPS-N Protocols defined to mark 'out of order':"
  1. F S I=$O(PPSN(I)) Q:I="" W !?8,I I $Y>20 R !,"Enter to continue...",X:120 W @IOF
  1. I $D(PPSN(2)) S I="" F S I=$O(PPSN(I)) Q:I="" W !," "_PPSN(I)
  1. R !!,"Protocol: ",Y:120
  1. I $G(Y)=""!(Y=-1)!($G(DTOUT))!($G(DIRUT))!($G(DUOUT)) S PPG="" Q
  1. 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
  1. I Y="??" W @IOF D SHELP R !,"Enter to continue...",X:120 G DIPRO1
  1. ;
  1. ;set all beginning with a prefix
  1. I Y["*" S ALLOF=$P(Y,"*"),LENGTH=$L(ALLOF) D G DIPRO1
  1. .F S III=$O(^ORD(101,"B",III)) Q:III="" S IV="" F S IV=$O(^ORD(101,"B",III,IV)) Q:IV="" D
  1. ..S ALLNAM=$$GET1^DIQ(101,IV,.01,"E")
  1. ..Q:ALLNAM=""
  1. ..S ALLOF2=$E(ALLNAM,1,LENGTH)
  1. ..I ALLOF=ALLOF2 D
  1. ...Q:$D(^PS(57.23,1,3.2,"B",IV))
  1. ...S DIC="^PS(57.23,1,3.2,",DA(1)=1
  1. ...S FDA(57.2332,"+1,1,",.01)=IV
  1. ...D UPDATE^DIE("","FDA","","ERROR")
  1. ;
  1. ;delete all beginning with a prefix
  1. I Y["@" S ALLOF=$P(Y,"@"),LENGTH=$L(ALLOF) D G DIPRO1
  1. .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
  1. .S DIR(0)="Y"
  1. .D ^DIR
  1. .Q:'$G(Y)
  1. .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
  1. ..S ALLNAM=$$GET1^DIQ(101,III,.01,"E")
  1. ..I ALLNAM'="" D
  1. ...S ALLOF2="",ALLOF2=$E(ALLNAM,1,LENGTH)
  1. ...Q:ALLOF'=ALLOF2
  1. ...K DIK,DIC S (DIK,DIC)="^PS(57.23,1,3.2,"
  1. ...S DA(1)=1,DA=IV,DR=".01///@" D ^DIK K DIR
  1. ;
  1. ;
  1. DIPRO2 ;
  1. K DIC S DIC="^ORD(101,",DIC(0)="EQMZ",X=Y D ^DIC
  1. I ($G(DTOUT))!($G(DIRUT))!($G(DUOUT)) S PPG="" G DIPRO1
  1. I 'Y!(Y=-1) W !!,"Selection not found.",! R !,"Enter to continue...",X:120 G DIPRO1
  1. S (SCHED,FILEIEN,MENUN)="",SCHED=$P(Y,"^")
  1. I $D(^TMP("PSNPPSNR",$J,SCHED)) S FILEIEN=^TMP("PSNPPSNR",$J,SCHED),MENUN=$$GET1^DIQ(101,SCHED,.01,"E")
  1. G DIPRO1:'Y!(Y=-1)!($G(DTOUT))!($G(DIRUT))!($G(DUOUT))
  1. ;
  1. DIPRO3 ;
  1. I $D(SCHED),$D(^TMP("PSNPPSNR",$J,SCHED)) D Q
  1. .K DIR S DIR("?")="Please enter Y or N.",DIR("B")="NO"
  1. .S DIR("A")="Do you want to delete it from the PPS-N Control file",DIR(0)="Y"
  1. .D ^DIR
  1. .K DIK,DIC S (DIK,DIC)="^PS(57.23,1,3.2,",DA(1)=1
  1. .I $G(Y) S DA(1)=1,DA=FILEIEN,DR=".01///@" D ^DIK K DIR
  1. .Q:$G(DUOUT)!($G(DIRUT))!($G(DTOUT))!('$G(Y))
  1. S FDA(57.2332,"+1,1,",.01)=SCHED
  1. D UPDATE^DIE("","FDA","","ERROR")
  1. G DISPR
  1. Q
  1. ;
  1. SHELP ;
  1. W !,"You are building a list of options and/or protocols to be marked 'Out"
  1. W !,"Of Order'. You may enter them in several different ways:"
  1. W !,"You may simply enter an option or protocol name,"
  1. W !," or NAM for a listing all that begin with the characters 'NAM'"
  1. W !," or ^ to quit and exit the program,"
  1. W !," or ? to see a brief help prompt,"
  1. W !," or ?? to see this help screen again,"
  1. W !," or ??? to see all entries"
  1. W !," or NAM* to select everything that begins with the characters 'NAM'"
  1. W !," or NAM@ remove item that begin with the characters 'NAM'"
  1. W !
  1. Q