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 Apr 09, 2024@21:32:32 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
