- 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
