Routine: APCLDEMO

APCLDEMO ; IHS/CMI/LAB - Check for demo patients ; 29 Jun 2009  6:38 AM

 ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009

UPDATE ;create/update Demo Patient Search Template

 D INTRO

 S DIR(0)="Y",DIR("A")="Do you wish to continue",DIR("B")="Y" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) D XIT Q

 I 'Y D XIT Q

SELECT ;

 S APCLSTMP=$O(^DIBT("B","RPMS DEMO PATIENT NAMES",0))

 I APCLSTMP G N

 K DIC

 S DIC(0)="L",X="RPMS DEMO PATIENT NAMES",DIC="^DIBT(",DIADD=1,DLAYGO=.401,DIC("DR")="4///2" D ^DIC

 I Y=-1 W !!,"Unable to create search template." D XIT Q

 K DIC,DLAYGO,DIADD

 S APCLSTMP=+Y

 D ^XBFMK

N ;display the existing template patients

 D EP

 D XIT

XIT ;

 D EN^XBVK("APC")

 K DIR,DLAYGO,DIADD

 D ^XBFMK

INTRO ;

 W:$D(IOF) @IOF

 W !!,"CREATE/UPDATE ""DEMO"" PATIENT LIST"

 W !!,"This option is used to update a patient search template (list) that"

 W !,"contains the names of all of the ""demo"" or ""test"" patients in your"

 W !,"database.  This template will be used to exclude these patients from"

 W !,"all PCC Management reports.  "

 W !!

EP ;EP - CALLED FROM OPTION

 D EN

EOJ ;EP

 D EN^XBVK("APC")

 ;; ;

EN ;EP -- main entry point for

 D EN^VALM("APCL DEMO SEARCH TEMPLATE")

 D CLEAR^VALM1

 D FULL^VALM1

 W:$D(IOF) @IOF

 D EOJ

HDR ; -- header code

 S VALMHDR(1)="DEMO/TEST PATIENTS TO EXCLUDE FROM PCC MANAGEMENT REPORTS"

 S VALMHDR(2)="* Patients currently included in the "_$P(^DIBT(APCLSTMP,0),U)_" list"

 S X="",$E(X,7)="Patient Name",$E(X,40)="HRN"

 S VALMHDR(3)=X

INIT ; -- init variables and list array

 K APCLDEMO S APCLHIGH="",C=0

 S X=0 F  S X=$O(^DIBT(APCLSTMP,1,X)) Q:X'=+X  D

 .S C=C+1

 .S APCLDEMO(C,0)=C_")  "_$P(^DPT(X,0),U),$E(APCLDEMO(C,0),40)=$$HRN^AUPNPAT(X,DUZ(2))

 .S APCLDEMO("IDX",C,C)=X

.Q

 S (VALMCNT,APCLHIGH)=C

HELP ; -- help code

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

EXIT ; -- exit code

EXPND ; -- expand code

BACK ;go back to listman

 D TERM^VALM0

 S VALMBCK="R"

 D INIT

 D HDR

 K DIR

 K X,Y,Z,I

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

 D FULL^VALM1

ADD1 W !!

 NEW AUPNLK

 S AUPNLK("ALL")="",AUPNLK("INAC")=""

 K DIC S DIC=9000001,DIC(0)="AEMQ" D ^DIC K DIC

 I Y=-1 G ADDX

 I $D(^DIBT(APCLSTMP,1,+Y)) W !!,"That patient is already in the list." G ADD1

 S ^DIBT(APCLSTMP,1,+Y)=""

 G ADD1

ADDX ;

 D BACK

REM ;EP - REMOVE PATIENT FROM SEARCH TEMPLATE

W !

 S DIR(0)="NO^1:"_APCLHIGH,DIR("A")="Remove which Patient (enter the number from the list)"

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

 I Y="" W !,"No patient selected." G REMX

 I $D(DIRUT) W !,"No patient selected." G REMX

 D FULL^VALM1 W:$D(IOF) @IOF

 S APCLPATI=APCLDEMO("IDX",Y,Y)

 W !!,$P(^DPT(APCLPATI,0),U)," removed from list.",!!

 K ^DIBT(APCLSTMP,1,APCLPATI)

 K DIR S DIR(0)="E",DIR("A")="Press enter to continue" D ^DIR K DIR

REMX ;

 D BACK

APCLDEMO  ; IHS/CMI/LAB - Check for demo patients ; 29 Jun 2009  6:38 AM

 +1       ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009

 +2       ;

 +3       ;

 +4       ;

UPDATE    ;create/update Demo Patient Search Template

 +1        DO INTRO

 +2        SET DIR(0)="Y"

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

           SET DIR("B")="Y"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               DO XIT

               QUIT

 +4        IF 'Y

               DO XIT

               QUIT

SELECT    ;

 +1        SET APCLSTMP=$ORDER(^DIBT("B","RPMS DEMO PATIENT NAMES",0))

 +2        IF APCLSTMP

               GOTO N

 +3        KILL DIC

 +4        SET DIC(0)="L"

           SET X="RPMS DEMO PATIENT NAMES"

           SET DIC="^DIBT("

           SET DIADD=1

           SET DLAYGO=.401

           SET DIC("DR")="4///2"

           DO ^DIC

 +5        IF Y=-1

               WRITE !!,"Unable to create search template."

               DO XIT

               QUIT

 +6        KILL DIC,DLAYGO,DIADD

 +7        SET APCLSTMP=+Y

 +8        DO ^XBFMK

 +9       ;

N         ;display the existing template patients

 +1        DO EP

 +2        DO XIT

 +3        QUIT

XIT       ;

 +1        DO EN^XBVK("APC")

 +2        KILL DIR,DLAYGO,DIADD

 +3        DO ^XBFMK

 +4        QUIT

 +5       ;

INTRO     ;

 +1        IF $DATA(IOF)

               WRITE @IOF

 +2        WRITE !!,"CREATE/UPDATE ""DEMO"" PATIENT LIST"

 +3        WRITE !!,"This option is used to update a patient search template (list) that"

 +4        WRITE !,"contains the names of all of the ""demo"" or ""test"" patients in your"

 +5        WRITE !,"database.  This template will be used to exclude these patients from"

 +6        WRITE !,"all PCC Management reports.  "

 +7        WRITE !!

 +8        QUIT

 +9       ;

 +10      ;

 +11      ;

 +12      ;

EP        ;EP - CALLED FROM OPTION

 +1        DO EN

 +2        QUIT

EOJ       ;EP

 +1        DO EN^XBVK("APC")

 +2        QUIT

 +3       ;; ;

EN        ;EP -- main entry point for

 +1        DO EN^VALM("APCL DEMO SEARCH TEMPLATE")

 +2        DO CLEAR^VALM1

 +3        DO FULL^VALM1

 +4        IF $DATA(IOF)

               WRITE @IOF

 +5        DO EOJ

 +6        QUIT

 +7       ;

HDR       ; -- header code

 +1        SET VALMHDR(1)="DEMO/TEST PATIENTS TO EXCLUDE FROM PCC MANAGEMENT REPORTS"

 +2        SET VALMHDR(2)="* Patients currently included in the "_$PIECE(^DIBT(APCLSTMP,0),U)_" list"

 +3        SET X=""

           SET $EXTRACT(X,7)="Patient Name"

           SET $EXTRACT(X,40)="HRN"

 +4        SET VALMHDR(3)=X

 +5        QUIT

 +6       ;

INIT      ; -- init variables and list array

 +1        KILL APCLDEMO

           SET APCLHIGH=""

           SET C=0

 +2        SET X=0

FOR

               SET X=$ORDER(^DIBT(APCLSTMP,1,X))

               IF X'=+X

                   QUIT

               Begin DoDot:1

 +3                SET C=C+1

 +4                SET APCLDEMO(C,0)=C_")  "_$PIECE(^DPT(X,0),U)

                   SET $EXTRACT(APCLDEMO(C,0),40)=$$HRN^AUPNPAT(X,DUZ(2))

 +5                SET APCLDEMO("IDX",C,C)=X

 +6                QUIT

               End DoDot:1

 +7        SET (VALMCNT,APCLHIGH)=C

 +8        QUIT

 +9       ;

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       ;

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

 +1        DO FULL^VALM1

ADD1       WRITE !!

 +1        NEW AUPNLK

 +2        SET AUPNLK("ALL")=""

           SET AUPNLK("INAC")=""

 +3        KILL DIC

           SET DIC=9000001

           SET DIC(0)="AEMQ"

           DO ^DIC

           KILL DIC

 +4        IF Y=-1

               GOTO ADDX

 +5        IF $DATA(^DIBT(APCLSTMP,1,+Y))

               WRITE !!,"That patient is already in the list."

               GOTO ADD1

 +6        SET ^DIBT(APCLSTMP,1,+Y)=""

 +7        GOTO ADD1

ADDX      ;

 +1        DO BACK

 +2        QUIT

REM       ;EP - REMOVE PATIENT FROM SEARCH TEMPLATE

 +1        WRITE !

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

           SET DIR("A")="Remove which Patient (enter the number from the list)"

 +3        DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +4        IF Y=""

               WRITE !,"No patient selected."

               GOTO REMX

 +5        IF $DATA(DIRUT)

               WRITE !,"No patient selected."

               GOTO REMX

 +6        DO FULL^VALM1

           IF $DATA(IOF)

               WRITE @IOF

 +7        SET APCLPATI=APCLDEMO("IDX",Y,Y)

 +8        WRITE !!,$PIECE(^DPT(APCLPATI,0),U)," removed from list.",!!

 +9        KILL ^DIBT(APCLSTMP,1,APCLPATI)

 +10       KILL DIR

           SET DIR(0)="E"

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

           DO ^DIR

           KILL DIR

REMX      ;

 +1        DO BACK

 +2        QUIT

APCLDEMO.m