- GMPLSLRP ;ISP/TC - Problem Selection List Reports ;08/22/17 06:38
- ;;2.0;Problem List;**49**;Aug 25, 1994;Build 43
- ;
- ; External References:
- ; ICR 2056 $$GET1^DIQ
- ; ICR 10026 ^DIR
- ; ICR 10060 ^VA(200,"B"
- ; ICR 10104 $$REPEAT^XLFSTR
- ;
- GETUSRLT(GMPLULST,GMPLELST) ; Retrieve pre-existing user problem selection lists
- N GMPLUSR,GMPLDUZ,GMPLLNME,GMPLUSNM,GMPLST
- S (GMPLUSR,GMPLDUZ)=""
- F S GMPLUSR=$O(^VA(200,"B",GMPLUSR)) Q:GMPLUSR="" D
- . F S GMPLDUZ=$O(^VA(200,"B",GMPLUSR,GMPLDUZ)) Q:GMPLDUZ="" D
- . . S GMPLUSNM=$$GET1^DIQ(200,GMPLDUZ,.01) Q:'$L(GMPLUSNM)
- . . S GMPLLNME=$$GET1^DIQ(200,GMPLDUZ,125.1),GMPLST=$$GET1^DIQ(200,GMPLDUZ,125.1,"I")
- . . I '$L(GMPLLNME),GMPLST S GMPLELST(GMPLUSNM,GMPLST)=GMPLDUZ Q
- . . E Q:'$L(GMPLLNME)
- . . S GMPLULST(GMPLUSNM,GMPLLNME)=""
- Q
- ;
- GETCLNLT(GMPLCLST) ; Retrieve pre-existing clinic problem selection lists
- N GMPLCLIN,GMPLST,GMPLDA
- S (GMPLDA,GMPLST)=""
- F S GMPLST=$O(^GMPL(125,"B",GMPLST)) Q:GMPLST="" D
- . F S GMPLDA=$O(^GMPL(125,"B",GMPLST,GMPLDA)) Q:GMPLDA="" D
- . . S GMPLCLIN=$$GET1^DIQ(125,GMPLDA,.03) Q:GMPLCLIN=""
- . . S GMPLCLST(GMPLCLIN,GMPLST)=""
- Q
- ;
- PAGE(GMPLNUM,GMPLTITL) ; Print header and raise page number
- Q:'$G(GMPLNUM)
- I GMPLNUM'=1,$E(IOST,1,2)="C-" D Q:'GMPLNUM
- . N DIR,DTOUT,DIRUT,DUOUT,X,Y
- . S DIR(0)="E" D ^DIR
- . I $D(DTOUT)!($D(DUOUT)) S GMPLNUM=0
- W @IOF
- W GMPLTITL
- W ?70,"Page: ",GMPLNUM
- W !,$$REPEAT^XLFSTR("-",78)
- S GMPLNUM=GMPLNUM+1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMPLSLRP 1500 printed Mar 13, 2025@21:35:14 Page 2
- GMPLSLRP ;ISP/TC - Problem Selection List Reports ;08/22/17 06:38
- +1 ;;2.0;Problem List;**49**;Aug 25, 1994;Build 43
- +2 ;
- +3 ; External References:
- +4 ; ICR 2056 $$GET1^DIQ
- +5 ; ICR 10026 ^DIR
- +6 ; ICR 10060 ^VA(200,"B"
- +7 ; ICR 10104 $$REPEAT^XLFSTR
- +8 ;
- GETUSRLT(GMPLULST,GMPLELST) ; Retrieve pre-existing user problem selection lists
- +1 NEW GMPLUSR,GMPLDUZ,GMPLLNME,GMPLUSNM,GMPLST
- +2 SET (GMPLUSR,GMPLDUZ)=""
- +3 FOR
- SET GMPLUSR=$ORDER(^VA(200,"B",GMPLUSR))
- if GMPLUSR=""
- QUIT
- Begin DoDot:1
- +4 FOR
- SET GMPLDUZ=$ORDER(^VA(200,"B",GMPLUSR,GMPLDUZ))
- if GMPLDUZ=""
- QUIT
- Begin DoDot:2
- +5 SET GMPLUSNM=$$GET1^DIQ(200,GMPLDUZ,.01)
- if '$LENGTH(GMPLUSNM)
- QUIT
- +6 SET GMPLLNME=$$GET1^DIQ(200,GMPLDUZ,125.1)
- SET GMPLST=$$GET1^DIQ(200,GMPLDUZ,125.1,"I")
- +7 IF '$LENGTH(GMPLLNME)
- IF GMPLST
- SET GMPLELST(GMPLUSNM,GMPLST)=GMPLDUZ
- QUIT
- +8 IF '$TEST
- if '$LENGTH(GMPLLNME)
- QUIT
- +9 SET GMPLULST(GMPLUSNM,GMPLLNME)=""
- End DoDot:2
- End DoDot:1
- +10 QUIT
- +11 ;
- GETCLNLT(GMPLCLST) ; Retrieve pre-existing clinic problem selection lists
- +1 NEW GMPLCLIN,GMPLST,GMPLDA
- +2 SET (GMPLDA,GMPLST)=""
- +3 FOR
- SET GMPLST=$ORDER(^GMPL(125,"B",GMPLST))
- if GMPLST=""
- QUIT
- Begin DoDot:1
- +4 FOR
- SET GMPLDA=$ORDER(^GMPL(125,"B",GMPLST,GMPLDA))
- if GMPLDA=""
- QUIT
- Begin DoDot:2
- +5 SET GMPLCLIN=$$GET1^DIQ(125,GMPLDA,.03)
- if GMPLCLIN=""
- QUIT
- +6 SET GMPLCLST(GMPLCLIN,GMPLST)=""
- End DoDot:2
- End DoDot:1
- +7 QUIT
- +8 ;
- PAGE(GMPLNUM,GMPLTITL) ; Print header and raise page number
- +1 if '$GET(GMPLNUM)
- QUIT
- +2 IF GMPLNUM'=1
- IF $EXTRACT(IOST,1,2)="C-"
- Begin DoDot:1
- +3 NEW DIR,DTOUT,DIRUT,DUOUT,X,Y
- +4 SET DIR(0)="E"
- DO ^DIR
- +5 IF $DATA(DTOUT)!($DATA(DUOUT))
- SET GMPLNUM=0
- End DoDot:1
- if 'GMPLNUM
- QUIT
- +6 WRITE @IOF
- +7 WRITE GMPLTITL
- +8 WRITE ?70,"Page: ",GMPLNUM
- +9 WRITE !,$$REPEAT^XLFSTR("-",78)
- +10 SET GMPLNUM=GMPLNUM+1
- +11 QUIT
