GMPLBLD3 ; SLC/MKB -- Bld PL Selection Lists cont ;3/12/03 13:40
;;2.0;Problem List;**28**;Aug 25, 1994
;
; This routine invokes IA #3991
;
ASSIGN ; Assign list to clinic, users: Expects GMPLSLST
N DIE,DA,DR D FULL^VALM1 G:+$G(GMPLSLST)'>0 ASQ
I '$$VALLIST^GMPLBLD2(+GMPLSLST) D G ASQ
. W !!,$C(7),"This Selection List contains problems with inactive ICD9 codes associated with"
. W !,"them. The codes must be edited and corrected before the list can be assigned",!,"to users or clinics."
. W !!,"If you have edited the list during this session to correct inactive codes, "
. W !,"save the list prior to attempting to assign it."
. N DIR,DUOUT,DTOUT,DIRUT
. S DIR(0)="E" D ^DIR
. Q
;
W !!,"You may assign this list to a clinic as its default selection list,"
W !,"as well as to individual users as a preferred selection list.",!
S DA=+GMPLSLST,DR=.03,DIE="^GMPL(125," D ^DIE Q:$D(DTOUT)!($D(DUOUT))
D USERS("1") ; assign
ASQ S VALMBCK="R",VALMSG=$$MSG^GMPLX
Q
;
USERS(ADD) ; -- select user(s) to de-/assign list
N DIR,DIC,DIE,DR,DA,X,Y,GMPLUSER,GMPLI
Q:+$G(GMPLSLST)'>0 S GMPLUSER=""
S DIC="^VA(200,",DIC(0)="EQM",DIC("A")="Select USER: "
F D READ Q:+Y'>0 S GMPLUSER=GMPLUSER_U_+Y,DIC("A")="ANOTHER ONE: "
I '$L(GMPLUSER) W !!,"No users selected.",! Q
S DIR(0)="YA",DIR("A")="Are you ready? ",DIR("B")="NO"
S DIR("?",1)="Enter YES to "_$S(ADD:"assign",1:"remove")_" the "_$P(GMPLSLST,U,2)_" list "_$S(ADD:"to the",1:"from the")
S DIR("?")=($L(GMPLUSER,U)-1)_" user(s) selected; enter NO to exit."
D ^DIR Q:'Y
USR W !,$S(ADD:"Assigning ",1:"Removing ")_$P(GMPLSLST,U,2)_" list ..."
S DIE="^VA(200,",DR="125.1///"_$S(ADD:"/"_(+GMPLSLST),1:"@")
F GMPLI=1:1:$L(GMPLUSER,U) S DA=$P(GMPLUSER,U,GMPLI) I DA D
. W !?4,$P($G(^VA(200,DA,0)),U) D ^DIE
W !!,"DONE."
Q
;
READ ; prompt for username, respond
W !,DIC("A") R X:DTIME I '$T!("^"[X) S Y=-1 Q
I X="?" W !!,"Enter the name of the user you wish this list to be "_$S(ADD:"assigned to;",1:"removed from;"),!,"enter '??' to see users currently assigned this list, or '???' to see",!,"all users on this system.",! G READ
I X?1"??".E D G READ
. I X="??" S DIC("S")="I $P($G(^(125)),U,2)="_+GMPLSLST W !!,"Users currently assigned "_$P(GMPLSLST,U,2)_" list:"
. S D="B",DZ="??" D DQ^DICQ K D,DZ,DIC("S")
D ^DIC G:Y'>0 READ
Q
;
DELETE ; Delete Selection List
N DIR,DIK,DA,X,Y,VIEW,USER,GMPCOUNT,GMPQUIT,GMPLSLST
S GMPCOUNT=0,GMPLSLST=$$LIST^GMPLBLD2("") Q:GMPLSLST="^"
W !!,"Checking the New Person file for use of this list ..."
F USER=0:0 S USER=$O(^VA(200,USER)) Q:USER'>0 D
. S VIEW=$P($G(^VA(200,USER,125)),U,2) Q:'VIEW Q:VIEW'=+GMPLSLST
. S GMPCOUNT=GMPCOUNT+1 W "."
I GMPCOUNT W $C(7),!!,GMPCOUNT_" user(s) are currently assigned this list!",!,"CANNOT DELETE",! Q
W !,"0 users found."
DEL1 S DIR(0)="Y",DIR("B")="NO"
S DIR("A")="Are you sure you want to delete this list"
S DIR("?",1)="Enter YES if you wish to completely remove this list; press <return>",DIR("?")="to leave this list unchanged and exit this option."
W $C(7),! D ^DIR Q:'Y
W !!,"Deleting "_$P(GMPLSLST,U,2)_" selection list ..."
S DIK="^GMPL(125.1,",DA=0 ; list contents
F S DA=$O(^GMPL(125.1,"B",+GMPLSLST,DA)) Q:DA'>0 D ^DIK W "."
S DA=+GMPLSLST,DIK="^GMPL(125," D ^DIK W "." ; list
W !,"DONE.",!
Q
;
; Expects GMPLSLST=selection list
N GSEQ,PSEQ,GCNT,PCNT,GROUP,HDR,IFN,LCNT,ITEM,TEXT,CODE
S (GSEQ,GCNT,LCNT)=0 K ^TMP("GMPLMENU",$J)
W !!,"Retrieving list of "_$P(GMPLSLST,U,2)_" problems ..."
F S GSEQ=$O(^GMPL(125.1,"C",+GMPLSLST,GSEQ)) Q:GSEQ'>0 D
. S IFN=$O(^GMPL(125.1,"C",+GMPLSLST,GSEQ,0)) Q:IFN'>0
. S ITEM=$G(^GMPL(125.1,IFN,0)),GROUP=$P(ITEM,U,3),HDR=$P(ITEM,U,4,5)
. S GCNT=GCNT+1,(PSEQ,PCNT)=0,^TMP("GMPLMENU",$J,GCNT,0)=HDR
. F S PSEQ=$O(^GMPL(125.12,"C",+GROUP,PSEQ)) Q:PSEQ'>0 D
. . S IFN=$O(^GMPL(125.12,"C",+GROUP,PSEQ,0)) Q:IFN'>0
. . S ITEM=$G(^GMPL(125.12,IFN,0)),TEXT=$P(ITEM,U,4),CODE=$P(ITEM,U,5)
. . I $L(CODE),'$$STATCHK^ICDAPIU(CODE,DT) Q ; screen inactive codes
. . S PCNT=PCNT+1,^TMP("GMPLMENU",$J,GCNT,PCNT)=$P(ITEM,U,3,5)
I '$D(^TMP("GMPLMENU",$J)) W !!,"No items available. Returning to Problem List ..." H 2 S VALMBCK="Q",VALMQUIT=1 Q
D BUILD^GMPLMENU
Q
GMPLBLD3 ; SLC/MKB -- Bld PL Selection Lists cont ;3/12/03 13:40
+1 ;;2.0;Problem List;**28**;Aug 25, 1994
+2 ;
+3 ; This routine invokes IA #3991
+4 ;
ASSIGN ; Assign list to clinic, users: Expects GMPLSLST
+1 NEW DIE,DA,DR
DO FULL^VALM1
IF +$GET(GMPLSLST)'>0
GOTO ASQ
+2 IF '$$VALLIST^GMPLBLD2(+GMPLSLST)
Begin DoDot:1
+3 WRITE !!,$CHAR(7),"This Selection List contains problems with inactive ICD9 codes associated with"
+4 WRITE !,"them. The codes must be edited and corrected before the list can be assigned",!,"to users or clinics."
+5 WRITE !!,"If you have edited the list during this session to correct inactive codes, "
+6 WRITE !,"save the list prior to attempting to assign it."
+7 NEW DIR,DUOUT,DTOUT,DIRUT
+8 SET DIR(0)="E"
DO ^DIR
+9 QUIT
End DoDot:1
GOTO ASQ
+10 ;
+11 WRITE !!,"You may assign this list to a clinic as its default selection list,"
+12 WRITE !,"as well as to individual users as a preferred selection list.",!
+13 SET DA=+GMPLSLST
SET DR=.03
SET DIE="^GMPL(125,"
DO ^DIE
IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+14 ; assign
DO USERS("1")
ASQ SET VALMBCK="R"
SET VALMSG=$$MSG^GMPLX
+1 QUIT
+2 ;
USERS(ADD) ; -- select user(s) to de-/assign list
+1 NEW DIR,DIC,DIE,DR,DA,X,Y,GMPLUSER,GMPLI
+2 IF +$GET(GMPLSLST)'>0
QUIT
SET GMPLUSER=""
+3 SET DIC="^VA(200,"
SET DIC(0)="EQM"
SET DIC("A")="Select USER: "
+4 FOR
DO READ
IF +Y'>0
QUIT
SET GMPLUSER=GMPLUSER_U_+Y
SET DIC("A")="ANOTHER ONE: "
+5 IF '$LENGTH(GMPLUSER)
WRITE !!,"No users selected.",!
QUIT
+6 SET DIR(0)="YA"
SET DIR("A")="Are you ready? "
SET DIR("B")="NO"
+7 SET DIR("?",1)="Enter YES to "_$SELECT(ADD:"assign",1:"remove")_" the "_$PIECE(GMPLSLST,U,2)_" list "_$SELECT(ADD:"to the",1:"from the")
+8 SET DIR("?")=($LENGTH(GMPLUSER,U)-1)_" user(s) selected; enter NO to exit."
+9 DO ^DIR
IF 'Y
QUIT
USR WRITE !,$SELECT(ADD:"Assigning ",1:"Removing ")_$PIECE(GMPLSLST,U,2)_" list ..."
+1 SET DIE="^VA(200,"
SET DR="125.1///"_$SELECT(ADD:"/"_(+GMPLSLST),1:"@")
+2 FOR GMPLI=1:1:$LENGTH(GMPLUSER,U)
SET DA=$PIECE(GMPLUSER,U,GMPLI)
IF DA
Begin DoDot:1
+3 WRITE !?4,$PIECE($GET(^VA(200,DA,0)),U)
DO ^DIE
End DoDot:1
+4 WRITE !!,"DONE."
+5 QUIT
+6 ;
READ ; prompt for username, respond
+1 WRITE !,DIC("A")
READ X:DTIME
IF '$TEST!("^"[X)
SET Y=-1
QUIT
+2 IF X="?"
WRITE !!,"Enter the name of the user you wish this list to be "_$SELECT(ADD:"assigned to;",1:"removed from;"),!,"enter '??' to see users currently assigned this list, or '???' to see",!,"all users on this system.",!
GOTO READ
+3 IF X?1"??".E
Begin DoDot:1
+4 IF X="??"
SET DIC("S")="I $P($G(^(125)),U,2)="_+GMPLSLST
WRITE !!,"Users currently assigned "_$PIECE(GMPLSLST,U,2)_" list:"
+5 SET D="B"
SET DZ="??"
DO DQ^DICQ
KILL D,DZ,DIC("S")
End DoDot:1
GOTO READ
+6 DO ^DIC
IF Y'>0
GOTO READ
+7 QUIT
+8 ;
DELETE ; Delete Selection List
+1 NEW DIR,DIK,DA,X,Y,VIEW,USER,GMPCOUNT,GMPQUIT,GMPLSLST
+2 SET GMPCOUNT=0
SET GMPLSLST=$$LIST^GMPLBLD2("")
IF GMPLSLST="^"
QUIT
+3 WRITE !!,"Checking the New Person file for use of this list ..."
+4 FOR USER=0:0
SET USER=$ORDER(^VA(200,USER))
IF USER'>0
QUIT
Begin DoDot:1
+5 SET VIEW=$PIECE($GET(^VA(200,USER,125)),U,2)
IF 'VIEW
QUIT
IF VIEW'=+GMPLSLST
QUIT
+6 SET GMPCOUNT=GMPCOUNT+1
WRITE "."
End DoDot:1
+7 IF GMPCOUNT
WRITE $CHAR(7),!!,GMPCOUNT_" user(s) are currently assigned this list!",!,"CANNOT DELETE",!
QUIT
+8 WRITE !,"0 users found."
DEL1 SET DIR(0)="Y"
SET DIR("B")="NO"
+1 SET DIR("A")="Are you sure you want to delete this list"
+2 SET DIR("?",1)="Enter YES if you wish to completely remove this list; press <return>"
SET DIR("?")="to leave this list unchanged and exit this option."
+3 WRITE $CHAR(7),!
DO ^DIR
IF 'Y
QUIT
+4 WRITE !!,"Deleting "_$PIECE(GMPLSLST,U,2)_" selection list ..."
+5 ; list contents
SET DIK="^GMPL(125.1,"
SET DA=0
+6 FOR
SET DA=$ORDER(^GMPL(125.1,"B",+GMPLSLST,DA))
IF DA'>0
QUIT
DO ^DIK
WRITE "."
+7 ; list
SET DA=+GMPLSLST
SET DIK="^GMPL(125,"
DO ^DIK
WRITE "."
+8 WRITE !,"DONE.",!
+9 QUIT
+10 ;
+1 ; Expects GMPLSLST=selection list
+2 NEW GSEQ,PSEQ,GCNT,PCNT,GROUP,HDR,IFN,LCNT,ITEM,TEXT,CODE
+3 SET (GSEQ,GCNT,LCNT)=0
KILL ^TMP("GMPLMENU",$JOB)
+4 WRITE !!,"Retrieving list of "_$PIECE(GMPLSLST,U,2)_" problems ..."
+5 FOR
SET GSEQ=$ORDER(^GMPL(125.1,"C",+GMPLSLST,GSEQ))
IF GSEQ'>0
QUIT
Begin DoDot:1
+6 SET IFN=$ORDER(^GMPL(125.1,"C",+GMPLSLST,GSEQ,0))
IF IFN'>0
QUIT
+7 SET ITEM=$GET(^GMPL(125.1,IFN,0))
SET GROUP=$PIECE(ITEM,U,3)
SET HDR=$PIECE(ITEM,U,4,5)
+8 SET GCNT=GCNT+1
SET (PSEQ,PCNT)=0
SET ^TMP("GMPLMENU",$JOB,GCNT,0)=HDR
+9 FOR
SET PSEQ=$ORDER(^GMPL(125.12,"C",+GROUP,PSEQ))
IF PSEQ'>0
QUIT
Begin DoDot:2
+10 SET IFN=$ORDER(^GMPL(125.12,"C",+GROUP,PSEQ,0))
IF IFN'>0
QUIT
+11 SET ITEM=$GET(^GMPL(125.12,IFN,0))
SET TEXT=$PIECE(ITEM,U,4)
SET CODE=$PIECE(ITEM,U,5)
+12 ; screen inactive codes
IF $LENGTH(CODE)
IF '$$STATCHK^ICDAPIU(CODE,DT)
QUIT
+13 SET PCNT=PCNT+1
SET ^TMP("GMPLMENU",$JOB,GCNT,PCNT)=$PIECE(ITEM,U,3,5)
End DoDot:2
End DoDot:1
+14 IF '$DATA(^TMP("GMPLMENU",$JOB))
WRITE !!,"No items available. Returning to Problem List ..."
HANG 2
SET VALMBCK="Q"
SET VALMQUIT=1
QUIT
+15 DO BUILD^GMPLMENU
+16 QUIT
