BDMDGTSN.m

BDMDGTSN ; IHS/CMI/LAB - DISPLAY IND LISTS ;

 ;;2.0;DIABETES MANAGEMENT SYSTEM;**12**;JUN 14, 2007;Build 51

 ;; ;

EP ;EP - CALLED FROM OPTION

 D EN

 Q

EOJ ;EP

 I '$D(BDMGUI) D EN^XBVK("BDM")

 Q

 ;; ;

EN ;EP -- main entry point for 

 D EN^VALM("BDMDG SNOMED VIEW")

 D CLEAR^VALM1

 D FULL^VALM1

 W:$D(IOF) @IOF

 D EOJ

 Q

 ;

PAUSE ;EP

 Q:$E(IOST)'="C"!(IO'=IO(0))

 W ! S DIR(0)="EO",DIR("A")="Press enter to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 Q

HDR ; -- header code

 S VALMHDR(1)="SNOMED LISTS TO SUPPORT 2019 DIABETES AUDIT REPORTING"

 S VALMHDR(2)="* View SNOMED Lists"

 Q

 ;

INIT ;EP -- init variables and list array

 K BDMTAX S BDMHIGH="",C=0

 S BDMYR=$O(^BDMSNME("B",2019,0))

 S BDMX=0,J=0 F  S BDMX=$O(^BDMSNME(BDMYR,11,"B",BDMX)) Q:BDMX=""  D

 .S BDMY=$O(^BDMSNME(BDMYR,11,"B",BDMX,0))

 .S J=J+1

 .S BDMTAX(J,0)=J_")  "_BDMX

 .S BDMTAX("IDX",J,J)=BDMYR_U_BDMY

 .S C=C+1

 .Q

 S (VALMCNT,BDMHIGH)=C

 Q

 ;

HELP ; -- help code

 S X="?" D DISP^XQORM1 W !!

 Q

 ;

EXIT ; -- exit code

 Q

 ;

EXPND ; -- expand code

 Q

 ;

BACK ;go back to listman

 D TERM^VALM0

 S VALMBCK="R"

 D INIT

 D HDR

 K DIR

 K X,Y,Z,I

 Q

 ;

DISP ;EP - add an item to the selected list - called from a protocol

 W !

 S DIR(0)="NO^1:"_BDMHIGH,DIR("A")="Which SNOMED List"

 D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I Y="" W !,"No list selected." G DISPX

 I $D(DIRUT) W !,"No list selected." G DISPX

 S BDMTAXI=$P(BDMTAX("IDX",Y,Y),U,1),BDMTAXT=$P(BDMTAX("IDX",Y,Y),U,2),BDMTAXN=$P(^BDMSNME(BDMTAXI,11,BDMTAXT,0),U,1)

 ;BROWSE OR PRINT

 D FULL^VALM1

 W ! S DIR(0)="S^P:PRINT SNOMED List Output;B:BROWSE SNOMED List Output on Screen",DIR("A")="Do you wish to",DIR("B")="P" K DA D ^DIR K DIR

 I $D(DIRUT) D XIT Q

 S BDMOPT=Y

 I Y="B" D BROWSE,XIT Q

 S XBRP="PRINT^BDMDGTSN",XBRC="",XBRX="XIT^BDMDGTSN",XBNS="BDM"

 D ^XBDBQUE

 D DISPX

 Q

BROWSE ;

 S XBRP="VIEWR^XBLM(""PRINT^BDMDGTSN"")"

 S XBRC="",XBRX="XIT^BDMDGTSN",XBIOP=0 D ^XBDBQUE

 Q

PHDR ;

 I 'BDMPG G HEAD1

 I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BDMQ="" Q

HEAD1 ;

 W:$D(IOF) @IOF S BDMPG=BDMPG+1

 I $G(BDMGUI),BDMPG'=1 W !,"ZZZZZZZ"

 W !,$P(^VA(200,DUZ,0),U,2),?72,"Page ",BDMPG,!

 W ?(80-$L($P(^DIC(4,$S($G(BDMDUZ2):BDMDUZ2,1:DUZ(2)),0),U))/2),$P(^DIC(4,$S($G(BDMDUZ2):BDMDUZ2,1:DUZ(2)),0),U),!

 W $$CTR("Listing of the "_BDMTAXN_" SNOMED List",80),!,BDM80D,!

 Q

PRINT ;

 S BDMPG=0

 K BDMQ

 S BDM80D="-------------------------------------------------------------------------------"

 D PHDR

P1 ;

 F  S BDMX=$O(^BDMSNME(BDMTAXI,11,BDMTAXT,11,"B",BDMX)) Q:BDMX=""  D

 .I $Y>(IOSL-3) D PHDR Q:$D(BDMQ)

 .W BDMX D

 ..I $T(CONC^BSTSAPI)="" Q

 ..NEW D,B,E,V,A,B

 ..W ?25,$P($$CONC^BSTSAPI(BDMX_"^^^1"),U,4),!

 D XIT

 Q

DISPX ;

 D BACK

 Q

XIT ;

 K ^TMP($J,"BDMTAXDSP")

 Q

CTR(X,Y) ;EP - Center X in a field Y wide.

 Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X

 ;----------

BDMDGTSN  ; IHS/CMI/LAB - DISPLAY IND LISTS ;

 +1       ;;2.0;DIABETES MANAGEMENT SYSTEM;**12**;JUN 14, 2007;Build 51

 +2       ;; ;

EP        ;EP - CALLED FROM OPTION

 +1        DO EN

 +2        QUIT 

EOJ       ;EP

 +1        IF '$DATA(BDMGUI)

               DO EN^XBVK("BDM")

 +2        QUIT 

 +3       ;; ;

EN        ;EP -- main entry point for 

 +1        DO EN^VALM("BDMDG SNOMED VIEW")

 +2        DO CLEAR^VALM1

 +3        DO FULL^VALM1

 +4        IF $DATA(IOF)

               WRITE @IOF

 +5        DO EOJ

 +6        QUIT 

 +7       ;

PAUSE     ;EP

 +1        IF $EXTRACT(IOST)'="C"!(IO'=IO(0))

               QUIT 

 +2        WRITE !

           SET DIR(0)="EO"

           SET DIR("A")="Press enter to continue...."

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +3        QUIT 

HDR       ; -- header code

 +1        SET VALMHDR(1)="SNOMED LISTS TO SUPPORT 2019 DIABETES AUDIT REPORTING"

 +2        SET VALMHDR(2)="* View SNOMED Lists"

 +3        QUIT 

 +4       ;

INIT      ;EP -- init variables and list array

 +1        KILL BDMTAX

           SET BDMHIGH=""

           SET C=0

 +2        SET BDMYR=$ORDER(^BDMSNME("B",2019,0))

 +3        SET BDMX=0

           SET J=0

           FOR 

               SET BDMX=$ORDER(^BDMSNME(BDMYR,11,"B",BDMX))

               IF BDMX=""

                   QUIT 

               Begin DoDot:1

 +4                SET BDMY=$ORDER(^BDMSNME(BDMYR,11,"B",BDMX,0))

 +5                SET J=J+1

 +6                SET BDMTAX(J,0)=J_")  "_BDMX

 +7                SET BDMTAX("IDX",J,J)=BDMYR_U_BDMY

 +8                SET C=C+1

 +9                QUIT 

               End DoDot:1

 +10       SET (VALMCNT,BDMHIGH)=C

 +11       QUIT 

 +12      ;

HELP      ; -- help code

 +1        SET X="?"

           DO DISP^XQORM1

           WRITE !!

 +2        QUIT 

 +3       ;

EXIT      ; -- exit code

 +1        QUIT 

 +2       ;

EXPND     ; -- expand code

 +1        QUIT 

 +2       ;

BACK      ;go back to listman

 +1        DO TERM^VALM0

 +2        SET VALMBCK="R"

 +3        DO INIT

 +4        DO HDR

 +5        KILL DIR

 +6        KILL X,Y,Z,I

 +7        QUIT 

 +8       ;

DISP      ;EP - add an item to the selected list - called from a protocol

 +1        WRITE !

 +2        SET DIR(0)="NO^1:"_BDMHIGH

           SET DIR("A")="Which SNOMED List"

 +3        DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +4        IF Y=""

               WRITE !,"No list selected."

               GOTO DISPX

 +5        IF $DATA(DIRUT)

               WRITE !,"No list selected."

               GOTO DISPX

 +6        SET BDMTAXI=$PIECE(BDMTAX("IDX",Y,Y),U,1)

           SET BDMTAXT=$PIECE(BDMTAX("IDX",Y,Y),U,2)

           SET BDMTAXN=$PIECE(^BDMSNME(BDMTAXI,11,BDMTAXT,0),U,1)

 +7       ;BROWSE OR PRINT

 +8        DO FULL^VALM1

 +9        WRITE !

           SET DIR(0)="S^P:PRINT SNOMED List Output;B:BROWSE SNOMED List Output on Screen"

           SET DIR("A")="Do you wish to"

           SET DIR("B")="P"

           KILL DA

           DO ^DIR

           KILL DIR

 +10       IF $DATA(DIRUT)

               DO XIT

               QUIT 

 +11       SET BDMOPT=Y

 +12       IF Y="B"

               DO BROWSE

               DO XIT

               QUIT 

 +13       SET XBRP="PRINT^BDMDGTSN"

           SET XBRC=""

           SET XBRX="XIT^BDMDGTSN"

           SET XBNS="BDM"

 +14       DO ^XBDBQUE

 +15       DO DISPX

 +16       QUIT 

BROWSE    ;

 +1        SET XBRP="VIEWR^XBLM(""PRINT^BDMDGTSN"")"

 +2        SET XBRC=""

           SET XBRX="XIT^BDMDGTSN"

           SET XBIOP=0

           DO ^XBDBQUE

 +3        QUIT 

PHDR      ;

 +1        IF 'BDMPG

               GOTO HEAD1

 +2        IF $EXTRACT(IOST)="C"

               IF IO=IO(0)

                   WRITE !

                   SET DIR(0)="EO"

                   DO ^DIR

                   KILL DIR

                   IF Y=0!(Y="^")!($DATA(DTOUT))

                       SET BDMQ=""

                       QUIT 

HEAD1     ;

 +1        IF $DATA(IOF)

               WRITE @IOF

           SET BDMPG=BDMPG+1

 +2        IF $GET(BDMGUI)

               IF BDMPG'=1

                   WRITE !,"ZZZZZZZ"

 +3        WRITE !,$PIECE(^VA(200,DUZ,0),U,2),?72,"Page ",BDMPG,!

 +4        WRITE ?(80-$LENGTH($PIECE(^DIC(4,$SELECT($GET(BDMDUZ2):BDMDUZ2,1:DUZ(2)),0),U))/2),$PIECE(^DIC(4,$SELECT($GET(BDMDUZ2):BDMDUZ2,1:DUZ(2)),0),U),!

 +5        WRITE $$CTR("Listing of the "_BDMTAXN_" SNOMED List",80),!,BDM80D,!

 +6        QUIT 

PRINT     ;

 +1        SET BDMPG=0

 +2        KILL BDMQ

 +3        SET BDM80D="-------------------------------------------------------------------------------"

 +4        DO PHDR

P1        ;

 +1        FOR 

               SET BDMX=$ORDER(^BDMSNME(BDMTAXI,11,BDMTAXT,11,"B",BDMX))

               IF BDMX=""

                   QUIT 

               Begin DoDot:1

 +2                IF $Y>(IOSL-3)

                       DO PHDR

                       IF $DATA(BDMQ)

                           QUIT 

 +3                WRITE BDMX

                   Begin DoDot:2

 +4                    IF $TEXT(CONC^BSTSAPI)=""

                           QUIT 

 +5                    NEW D,B,E,V,A,B

 +6                    WRITE ?25,$PIECE($$CONC^BSTSAPI(BDMX_"^^^1"),U,4),!

                   End DoDot:2

               End DoDot:1

 +7        DO XIT

 +8        QUIT 

DISPX     ;

 +1        DO BACK

 +2        QUIT 

XIT       ;

 +1        KILL ^TMP($JOB,"BDMTAXDSP")

 +2        QUIT 

CTR(X,Y)  ;EP - Center X in a field Y wide.

 +1        QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X

 +2       ;----------