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 Dec 13, 2024@02:29:48 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
