Routine: APCLSTMP

APCLSTMP ; IHS/CMI/LAB - CREATE SEARCH TEMPLATE FOR PGEN (PATIENT) REPORTS ;

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

EN ;EP - ENTRY POINT

 D EN1

EXIT K APCLSDIC,APCLSNAM,APCLSTN,DHD

EN1 ;EP Help

 K APCLQUIT

W !

 W ?10,"*** You may enter an existing Template Name ***",! W ?30,"OR",! W ?12,"*** Save results in a New Template ***",! W ?30,"OR",! W ?25,"'^' to Exit",!!

EN2 K DIC,DLAYGO S DLAYGO=.401,DIC="^DIBT(",DIC(0)="AELMQZ",DIC("A")="Patient Search Template: ",DIC("S")="I $P(^(0),U,4)=9000001&($P(^(0),U,5)=DUZ)"

W !

 D ^DIC K DIC,DLAYGO

 I +Y<1 W !!,"No Search Template selected." H 2 S APCLQUIT=1 Q

 S APCLSTMP=+Y,APCLSNAM=$P(^DIBT(APCLSTMP,0),U)

DUP I '$P(Y,U,3) D  I Q K APCLSTMP,Y G EN2

 .S Q=""

 .W !!,$C(7),$C(7)

 .S DIR(0)="Y",DIR("A")="That template already exists!!  Do you want to overwrite it",DIR("B")="N" K DA D ^DIR K DIR

 .I $D(DIRUT) S Q=1 Q

 .I 'Y S Q=1 Q

 .L +^DIBT(APCLSTMP):10

 .S APCLSTN=$P(^DIBT(APCLSTMP,0),U) S DA=APCLSTMP,DIK="^DIBT(" D ^DIK

 .S ^DIBT(APCLSTMP,0)=APCLSNAM,DA=APCLSTMP,DIK="^DIBT(" D IX1^DIK

 .L -^DIBT(APCLSTMP)

.Q

 I APCLSTMP,$D(^DIBT(APCLSTMP)) D

 .W !!,?5,"An unduplicated PATIENT list resulting from this report",!,?5,"will be stored in the.........>",!!?18,"**  ",APCLSNAM,"  ** Search Template."

 .K ^DIBT(APCLSTMP,1)

 .S DHIT="S ^DIBT("_APCLSTMP_",1,DFN)="""""

 .S DIE="^DIBT(",DA=APCLSTMP,DR="2////"_DT_";3////M;4////9000001;5////"_DUZ_";6////M"

 .D ^DIE

 .K DIE,DA,DR

;Q

 ;Run Template in Background Mode

SETRECS ;EP - Set Entries into Template

 S APCLDFN=0 F  S APCLDFN=$O(^XTMP("APCLVL",APCLJOB,APCLBTH,"PATIENTS",APCLDFN)) Q:APCLDFN'=+APCLDFN  D

 .I '$D(^XTMP("APCLVL",APCLJOB,APCLBTH)) W !!,"NO DATA TO REPORT.",! D PAUSE^APCLVL01 W:$D(IOF) @IOF

 .S ^DIBT(APCLSTMP,1,APCLDFN)=""""

APCLSTMP  ; IHS/CMI/LAB - CREATE SEARCH TEMPLATE FOR PGEN (PATIENT) REPORTS ;

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

 +2       ;

EN        ;EP - ENTRY POINT

 +1        DO EN1

EXIT       KILL APCLSDIC,APCLSNAM,APCLSTN,DHD

 +1        QUIT

EN1       ;EP Help

 +1        KILL APCLQUIT

 +2        WRITE !

 +3        WRITE ?10,"*** You may enter an existing Template Name ***",!

           WRITE ?30,"OR",!

           WRITE ?12,"*** Save results in a New Template ***",!

           WRITE ?30,"OR",!

           WRITE ?25,"'^' to Exit",!!

EN2        KILL DIC,DLAYGO

           SET DLAYGO=.401

           SET DIC="^DIBT("

           SET DIC(0)="AELMQZ"

           SET DIC("A")="Patient Search Template: "

           SET DIC("S")="I $P(^(0),U,4)=9000001&($P(^(0),U,5)=DUZ)"

 +1        WRITE !

 +2        DO ^DIC

           KILL DIC,DLAYGO

 +3        IF +Y<1

               WRITE !!,"No Search Template selected."

               HANG 2

               SET APCLQUIT=1

               QUIT

 +4        SET APCLSTMP=+Y

           SET APCLSNAM=$PIECE(^DIBT(APCLSTMP,0),U)

DUP        IF '$PIECE(Y,U,3)

               Begin DoDot:1

 +1                SET Q=""

 +2                WRITE !!,$CHAR(7),$CHAR(7)

 +3                SET DIR(0)="Y"

                   SET DIR("A")="That template already exists!!  Do you want to overwrite it"

                   SET DIR("B")="N"

                   KILL DA

                   DO ^DIR

                   KILL DIR

 +4                IF $DATA(DIRUT)

                       SET Q=1

                       QUIT

 +5                IF 'Y

                       SET Q=1

                       QUIT

 +6                LOCK +^DIBT(APCLSTMP):10

 +7                SET APCLSTN=$PIECE(^DIBT(APCLSTMP,0),U)

                   SET DA=APCLSTMP

                   SET DIK="^DIBT("

                   DO ^DIK

 +8                SET ^DIBT(APCLSTMP,0)=APCLSNAM

                   SET DA=APCLSTMP

                   SET DIK="^DIBT("

                   DO IX1^DIK

 +9                LOCK -^DIBT(APCLSTMP)

 +10               QUIT

               End DoDot:1

               IF Q

                   KILL APCLSTMP,Y

                   GOTO EN2

 +11       IF APCLSTMP

               IF $DATA(^DIBT(APCLSTMP))

                   Begin DoDot:1

 +12                   WRITE !!,?5,"An unduplicated PATIENT list resulting from this report",!,?5,"will be stored in the.........>",!!?18,"**  ",APCLSNAM,"  ** Search Template."

 +13                   KILL ^DIBT(APCLSTMP,1)

 +14                   SET DHIT="S ^DIBT("_APCLSTMP_",1,DFN)="""""

 +15                   SET DIE="^DIBT("

                       SET DA=APCLSTMP

                       SET DR="2////"_DT_";3////M;4////9000001;5////"_DUZ_";6////M"

 +16                   DO ^DIE

 +17                   KILL DIE,DA,DR

                   End DoDot:1

 +18      ;Q

 +19      ;Run Template in Background Mode

 +20      ;

 +21      ;

 +22       QUIT

 +23      ;

SETRECS   ;EP - Set Entries into Template

 +1       ;

 +2        SET APCLDFN=0

FOR

               SET APCLDFN=$ORDER(^XTMP("APCLVL",APCLJOB,APCLBTH,"PATIENTS",APCLDFN))

               IF APCLDFN'=+APCLDFN

                   QUIT

               Begin DoDot:1

 +3                IF '$DATA(^XTMP("APCLVL",APCLJOB,APCLBTH))

                       WRITE !!,"NO DATA TO REPORT.",!

                       DO PAUSE^APCLVL01

                       IF $DATA(IOF)

                           WRITE @IOF

 +4                SET ^DIBT(APCLSTMP,1,APCLDFN)=""""

               End DoDot:1

 +5        QUIT

APCLSTMP.m