- GMPLBLD3 ; SLC/MKB,TC -- Bld PL Selection Lists cont ;08/22/17 14:15
- ;;2.0;Problem List;**28,42,49**;Aug 25, 1994;Build 43
- ;
- ; External References:
- ; ICR 1966 $$GET1^DIQ(4.2,GMPLIFN,.01)
- ; ICR 2056 $$GET1^DIQ
- ; ICR 2263 ENVAL^XPAR
- ; ICR 4083 $$STATCHK^LEXSRC2
- ; ICR 5747 $$CODECS^ICDEX,$$STATCHK^ICDEX
- ; ICR 10103 $$DT^XLFDT
- ; ICR 10013 ^DIK
- ; ICR 10026 ^DIR
- ; ICR 10040 $$GET1^DIQ(44,GMPLIFN,.01)
- ; ICR 10060 $$GET1^DIQ(200,DUZ,.01)
- ; ICR 10090 $$GET1^DIQ(4,GMPLIFN,.01)
- ;
- DELETE ; Delete Selection List
- N DIR,DIK,DA,X,Y,GMPQUIT,GMPLSLST,GMPLSEQ,GMPLDA,GMPLFDA,GMPLMSG
- N GMPLPAR,GMPLERR,GMPLENT,GMPLVIEW,GMPCNT,GMPLPLST,GMPLENTY
- N GMPLUSR,GMPLDUZ,GMPLLST,GMPLERR1,GMPLTXT,GMPLUCNT,GMPLSUC
- S (GMPLENT,GMPLENTY,GMPLUSR,GMPLDUZ)="",(GMPCNT,GMPLUCNT)=0,GMPLSUC=1
- S GMPLSLST=$$LIST^GMPLBLD2("") Q:GMPLSLST="^"
- I $P($G(GMPLSLST),U,5)="N" W !!,"Cannot delete a National Selection List." G DELQT
- W !!,"Checking the Default Problem Selection List parameter for use of this list ..."
- D ENVAL^XPAR(.GMPLPAR,"ORQQPL SELECTION LIST",1,.GMPLERR)
- I +$G(GMPLERR)>0 W !!,"Error: "_$P(GMPLERR,U,2) G DELQT
- I GMPLPAR>1 D
- . F S GMPLENT=$O(GMPLPAR(GMPLENT)) Q:GMPLENT="" D
- . . S GMPLVIEW=$G(GMPLPAR(GMPLENT,1)) Q:'GMPLVIEW Q:GMPLVIEW'=+GMPLSLST
- . . S GMPCNT=GMPCNT+1,GMPLPLST(GMPLENT)="" W "."
- I GMPCNT D Q
- . W !!,"CANNOT DELETE",!,"This list is currently assigned to the following entities:",!!
- . F S GMPLENTY=$O(GMPLPLST(GMPLENTY)) Q:GMPLENTY="" D
- . . I GMPLENTY["VA(" W ?7,"User: "_$$GET1^DIQ(200,$P(GMPLENTY,";"),.01),! Q
- . . I GMPLENTY["SC(" W ?7,"Clinic: "_$$GET1^DIQ(44,$P(GMPLENTY,";"),.01),! Q
- . . I GMPLENTY["DIC(4.2" W ?7,"System: "_$$GET1^DIQ(4.2,$P(GMPLENTY,";"),.01),! Q
- . . I GMPLENTY["DIC(4" W ?7,"Division: "_$$GET1^DIQ(4,$P(GMPLENTY,";"),.01),! Q
- . G DELQT
- W !,"No other parameter settings 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 GMPLFDA(125,""_+GMPLSLST_",",.01)="@"
- D FILE^DIE("K","GMPLFDA","GMPLMSG")
- I $D(GMPLMSG) D EN^DDIOL("Error: "_GMPLMSG("DIERR",1,"TEXT",1))
- E D
- . W !,"DONE."
- . I $D(^GMPL(125,0)) S $P(^GMPL(125,0),U,3)=0
- W !!,"Checking the NEW PERSON file for any pointers to this list and removing them..."
- F S GMPLUSR=$O(^VA(200,"B",GMPLUSR)) Q:GMPLUSR="" D
- . F S GMPLDUZ=$O(^VA(200,"B",GMPLUSR,GMPLDUZ)) Q:GMPLDUZ="" D
- . . S GMPLLST=$$GET1^DIQ(200,GMPLDUZ,125.1,"I") Q:'GMPLLST
- . . I +GMPLSLST=GMPLLST D
- . . . S GMPLUCNT=GMPLUCNT+1
- . . . S GMPLFDA(200,""_GMPLDUZ_",",125.1)="@"
- . . . D FILE^DIE("K","GMPLFDA","GMPLERR1")
- . . . I $D(GMPLERR1) D
- . . . . S GMPLTXT(1)="Error deleting pointer #"_GMPLLST_" from user "_GMPLUSR_"."
- . . . . S GMPLTXT(2)="Error: "_GMPLERR("DIERR",1,"TEXT",1),GMPLSUC=0
- . . . . D EN^DDIOL(.GMPLTXT)
- I 'GMPLUCNT W !,"No pointers found." G DELQT
- I GMPLSUC W !,"DONE."
- DELQT W ! D PAUSE^GMPLX
- Q
- ;
- ; Expects GMPLSLST=selection list
- N GSEQ,PSEQ,GCNT,PCNT,GROUP,HDR,IFN,LCNT,ITEM,TEXT,GMPICD,GMPLCPTR,GMPSCTC,GMPDT
- S (GSEQ,GCNT,LCNT)=0,GMPDT=$$DT^XLFDT K ^TMP("GMPLMENU",$J)
- W !!,"Retrieving list of "_$P(GMPLSLST,U,2)_" problems ..."
- F S GSEQ=$O(^GMPL(125,"AD",+GMPLSLST,GSEQ)) Q:GSEQ'>0 D
- . S IFN=$O(^GMPL(125,"AD",+GMPLSLST,GSEQ,0)) Q:IFN'>0
- . S ITEM=$G(^GMPL(125,+GMPLSLST,1,IFN,0)),GROUP=$P(ITEM,U,1),HDR=$P(ITEM,U,3,4)
- . S GCNT=GCNT+1,(PSEQ,PCNT)=0,^TMP("GMPLMENU",$J,GCNT,0)=HDR
- . F S PSEQ=$O(^GMPL(125.11,"C",+GROUP,PSEQ)) Q:PSEQ'>0 D
- . . S IFN=$O(^GMPL(125.11,"C",+GROUP,PSEQ,0)) Q:IFN'>0
- . . S ITEM=$G(^GMPL(125.11,+GROUP,1,IFN,0)),TEXT=$P(ITEM,U,3)
- . . S GMPICD=$P(ITEM,U,4),GMPSCTC=$P(ITEM,U,5)
- . . I $L(GMPSCTC) D
- . . . I '$$STATCHK^LEXSRC2(GMPSCTC,GMPDT,"","SCT") Q
- . . I $L(GMPICD) D
- . . . N GMPLCPTR,GMI S GMPLCPTR=$P($$CODECS^ICDEX($P(GMPICD,"/"),80,GMPDT),U)
- . . . F GMI=1:1:$L(GMPICD,"/") D
- . . . . I '$$STATCHK^ICDEX($P(GMPICD,"/",GMI),GMPDT,GMPLCPTR) Q ; screen inactive codes
- . . S PCNT=PCNT+1,^TMP("GMPLMENU",$J,GCNT,PCNT)=$P(ITEM,U,1)_U_$P(ITEM,U,3,4)
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMPLBLD3 4540 printed Mar 13, 2025@21:34:35 Page 2
- GMPLBLD3 ; SLC/MKB,TC -- Bld PL Selection Lists cont ;08/22/17 14:15
- +1 ;;2.0;Problem List;**28,42,49**;Aug 25, 1994;Build 43
- +2 ;
- +3 ; External References:
- +4 ; ICR 1966 $$GET1^DIQ(4.2,GMPLIFN,.01)
- +5 ; ICR 2056 $$GET1^DIQ
- +6 ; ICR 2263 ENVAL^XPAR
- +7 ; ICR 4083 $$STATCHK^LEXSRC2
- +8 ; ICR 5747 $$CODECS^ICDEX,$$STATCHK^ICDEX
- +9 ; ICR 10103 $$DT^XLFDT
- +10 ; ICR 10013 ^DIK
- +11 ; ICR 10026 ^DIR
- +12 ; ICR 10040 $$GET1^DIQ(44,GMPLIFN,.01)
- +13 ; ICR 10060 $$GET1^DIQ(200,DUZ,.01)
- +14 ; ICR 10090 $$GET1^DIQ(4,GMPLIFN,.01)
- +15 ;
- DELETE ; Delete Selection List
- +1 NEW DIR,DIK,DA,X,Y,GMPQUIT,GMPLSLST,GMPLSEQ,GMPLDA,GMPLFDA,GMPLMSG
- +2 NEW GMPLPAR,GMPLERR,GMPLENT,GMPLVIEW,GMPCNT,GMPLPLST,GMPLENTY
- +3 NEW GMPLUSR,GMPLDUZ,GMPLLST,GMPLERR1,GMPLTXT,GMPLUCNT,GMPLSUC
- +4 SET (GMPLENT,GMPLENTY,GMPLUSR,GMPLDUZ)=""
- SET (GMPCNT,GMPLUCNT)=0
- SET GMPLSUC=1
- +5 SET GMPLSLST=$$LIST^GMPLBLD2("")
- if GMPLSLST="^"
- QUIT
- +6 IF $PIECE($GET(GMPLSLST),U,5)="N"
- WRITE !!,"Cannot delete a National Selection List."
- GOTO DELQT
- +7 WRITE !!,"Checking the Default Problem Selection List parameter for use of this list ..."
- +8 DO ENVAL^XPAR(.GMPLPAR,"ORQQPL SELECTION LIST",1,.GMPLERR)
- +9 IF +$GET(GMPLERR)>0
- WRITE !!,"Error: "_$PIECE(GMPLERR,U,2)
- GOTO DELQT
- +10 IF GMPLPAR>1
- Begin DoDot:1
- +11 FOR
- SET GMPLENT=$ORDER(GMPLPAR(GMPLENT))
- if GMPLENT=""
- QUIT
- Begin DoDot:2
- +12 SET GMPLVIEW=$GET(GMPLPAR(GMPLENT,1))
- if 'GMPLVIEW
- QUIT
- if GMPLVIEW'=+GMPLSLST
- QUIT
- +13 SET GMPCNT=GMPCNT+1
- SET GMPLPLST(GMPLENT)=""
- WRITE "."
- End DoDot:2
- End DoDot:1
- +14 IF GMPCNT
- Begin DoDot:1
- +15 WRITE !!,"CANNOT DELETE",!,"This list is currently assigned to the following entities:",!!
- +16 FOR
- SET GMPLENTY=$ORDER(GMPLPLST(GMPLENTY))
- if GMPLENTY=""
- QUIT
- Begin DoDot:2
- +17 IF GMPLENTY["VA("
- WRITE ?7,"User: "_$$GET1^DIQ(200,$PIECE(GMPLENTY,";"),.01),!
- QUIT
- +18 IF GMPLENTY["SC("
- WRITE ?7,"Clinic: "_$$GET1^DIQ(44,$PIECE(GMPLENTY,";"),.01),!
- QUIT
- +19 IF GMPLENTY["DIC(4.2"
- WRITE ?7,"System: "_$$GET1^DIQ(4.2,$PIECE(GMPLENTY,";"),.01),!
- QUIT
- +20 IF GMPLENTY["DIC(4"
- WRITE ?7,"Division: "_$$GET1^DIQ(4,$PIECE(GMPLENTY,";"),.01),!
- QUIT
- End DoDot:2
- +21 GOTO DELQT
- End DoDot:1
- QUIT
- +22 WRITE !,"No other parameter settings 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 SET GMPLFDA(125,""_+GMPLSLST_",",.01)="@"
- +6 DO FILE^DIE("K","GMPLFDA","GMPLMSG")
- +7 IF $DATA(GMPLMSG)
- DO EN^DDIOL("Error: "_GMPLMSG("DIERR",1,"TEXT",1))
- +8 IF '$TEST
- Begin DoDot:1
- +9 WRITE !,"DONE."
- +10 IF $DATA(^GMPL(125,0))
- SET $PIECE(^GMPL(125,0),U,3)=0
- End DoDot:1
- +11 WRITE !!,"Checking the NEW PERSON file for any pointers to this list and removing them..."
- +12 FOR
- SET GMPLUSR=$ORDER(^VA(200,"B",GMPLUSR))
- if GMPLUSR=""
- QUIT
- Begin DoDot:1
- +13 FOR
- SET GMPLDUZ=$ORDER(^VA(200,"B",GMPLUSR,GMPLDUZ))
- if GMPLDUZ=""
- QUIT
- Begin DoDot:2
- +14 SET GMPLLST=$$GET1^DIQ(200,GMPLDUZ,125.1,"I")
- if 'GMPLLST
- QUIT
- +15 IF +GMPLSLST=GMPLLST
- Begin DoDot:3
- +16 SET GMPLUCNT=GMPLUCNT+1
- +17 SET GMPLFDA(200,""_GMPLDUZ_",",125.1)="@"
- +18 DO FILE^DIE("K","GMPLFDA","GMPLERR1")
- +19 IF $DATA(GMPLERR1)
- Begin DoDot:4
- +20 SET GMPLTXT(1)="Error deleting pointer #"_GMPLLST_" from user "_GMPLUSR_"."
- +21 SET GMPLTXT(2)="Error: "_GMPLERR("DIERR",1,"TEXT",1)
- SET GMPLSUC=0
- +22 DO EN^DDIOL(.GMPLTXT)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +23 IF 'GMPLUCNT
- WRITE !,"No pointers found."
- GOTO DELQT
- +24 IF GMPLSUC
- WRITE !,"DONE."
- DELQT WRITE !
- DO PAUSE^GMPLX
- +1 QUIT
- +2 ;
- +1 ; Expects GMPLSLST=selection list
- +2 NEW GSEQ,PSEQ,GCNT,PCNT,GROUP,HDR,IFN,LCNT,ITEM,TEXT,GMPICD,GMPLCPTR,GMPSCTC,GMPDT
- +3 SET (GSEQ,GCNT,LCNT)=0
- SET GMPDT=$$DT^XLFDT
- KILL ^TMP("GMPLMENU",$JOB)
- +4 WRITE !!,"Retrieving list of "_$PIECE(GMPLSLST,U,2)_" problems ..."
- +5 FOR
- SET GSEQ=$ORDER(^GMPL(125,"AD",+GMPLSLST,GSEQ))
- if GSEQ'>0
- QUIT
- Begin DoDot:1
- +6 SET IFN=$ORDER(^GMPL(125,"AD",+GMPLSLST,GSEQ,0))
- if IFN'>0
- QUIT
- +7 SET ITEM=$GET(^GMPL(125,+GMPLSLST,1,IFN,0))
- SET GROUP=$PIECE(ITEM,U,1)
- SET HDR=$PIECE(ITEM,U,3,4)
- +8 SET GCNT=GCNT+1
- SET (PSEQ,PCNT)=0
- SET ^TMP("GMPLMENU",$JOB,GCNT,0)=HDR
- +9 FOR
- SET PSEQ=$ORDER(^GMPL(125.11,"C",+GROUP,PSEQ))
- if PSEQ'>0
- QUIT
- Begin DoDot:2
- +10 SET IFN=$ORDER(^GMPL(125.11,"C",+GROUP,PSEQ,0))
- if IFN'>0
- QUIT
- +11 SET ITEM=$GET(^GMPL(125.11,+GROUP,1,IFN,0))
- SET TEXT=$PIECE(ITEM,U,3)
- +12 SET GMPICD=$PIECE(ITEM,U,4)
- SET GMPSCTC=$PIECE(ITEM,U,5)
- +13 IF $LENGTH(GMPSCTC)
- Begin DoDot:3
- +14 IF '$$STATCHK^LEXSRC2(GMPSCTC,GMPDT,"","SCT")
- QUIT
- End DoDot:3
- +15 IF $LENGTH(GMPICD)
- Begin DoDot:3
- +16 NEW GMPLCPTR,GMI
- SET GMPLCPTR=$PIECE($$CODECS^ICDEX($PIECE(GMPICD,"/"),80,GMPDT),U)
- +17 FOR GMI=1:1:$LENGTH(GMPICD,"/")
- Begin DoDot:4
- +18 ; screen inactive codes
- IF '$$STATCHK^ICDEX($PIECE(GMPICD,"/",GMI),GMPDT,GMPLCPTR)
- QUIT
- End DoDot:4
- End DoDot:3
- +19 SET PCNT=PCNT+1
- SET ^TMP("GMPLMENU",$JOB,GCNT,PCNT)=$PIECE(ITEM,U,1)_U_$PIECE(ITEM,U,3,4)
- End DoDot:2
- End DoDot:1
- +20 IF '$DATA(^TMP("GMPLMENU",$JOB))
- WRITE !!,"No items available. Returning to Problem List ..."
- HANG 2
- SET VALMBCK="Q"
- SET VALMQUIT=1
- QUIT
- +21 DO BUILD^GMPLMENU
- +22 QUIT
