ACMGTP.m

ACMGTP ; IHS/TUCSON/TMJ - LOOKUP AND EDIT OF CMS REGISTER ; [ 02/10/2009  9:47 AM ]

 ;;2.0;ACM CASE MANAGEMENT SYSTEM;**5,6,8**;JAN 10, 1996

 ;PATCH #6 DISPLAYS REGISTER CREATOR TO NON-SECURED USER

EN ;PEP - SELECT AND CREATE A REGISTER

 D RGTP

EXIT K ACMU1,ACMU11,ACMX,ACMI,ACMJ,ACM,ACMQKI,ACMQK,ACMY,ACMRGCUS,ACMRGMGR,ACMRGUSR,ACMQUIT,ACMOLDN,ACMNEWN

 K ACMQUIT,ACMZ

 I '$D(ACMRGTP) K ACMRG,ACMRGNA

 Q

RGTP ;EP;TO SELECT AND CREATE A REGISTER

 D HEAD^ACMMENU

RGTPX ;EP;SELECT/CREATE REG W/O HEADER

 S ACMX="REGISTER SELECTION UTILITY"

 W !!,?80-$L(ACMX)\2,ACMX,!

 K:$D(ACMRGTP) ACMRGMGR,ACMRGUSR,ACMRGCUS

 K:$D(ACMRGMGR) ACMRGTP,ACMRGUSR

 K:$D(ACMRGUSR) ACMRGMGR,ACMRGTP,ACMRGCUS

 K:$D(ACMRGCUS) ACMRGTP,ACMRGUSR

 S ACMRGX(3)="I '$D(^ACM(41.1,ACMRG,""AU"",""B"",DUZ)) S ACMJ=ACMJ-1",ACMRGX(4)="I $D(^ACM(41.1,ACMRG,""AU"",""B"",DUZ)) X ACMRGX(5)",ACMRGX(5)="W:ACMJ#2=1 !?14 W:ACMJ#2=0 ?45 W ACMRGX"

 S ACMRGX=""

 F ACMJ=1:1 S ACMRGX=$O(^ACM(41.1,"B",ACMRGX)) Q:ACMRGX=""  D RGTPA

 K ACMRG,ACMRGX,ACMJ,ACMI

 D RGTP1,EXIT

 Q

RGTPA S ACMRG="",ACMRG=$O(^ACM(41.1,"B",ACMRGX,ACMRG))

 X:$D(ACMRGTP) ACMRGX(3)

 X:$D(ACMRGTP) ACMRGX(4)

 X:'$D(ACMRGTP) ACMRGX(5)

 Q

RGTP1 I $D(ACMRGUSR) S ACMRGUSR=DUZ,DIC(0)="AEMQZ"

 I $D(ACMRGCUS) S ACMRGCUS=DUZ,DIC(0)="AEMQZ"

 I $D(ACMRGTP) S DIC(0)="AEMQZ"

 I $D(ACMRGMGR) S ACMRGMGR=DUZ,DIC(0)="AELMQZ",DLAYGO=9002241

 S (DIC,DIE)="^ACM(41.1,",DIC("A")="    REGISTER: "

 I $D(ACMRGTP) S ACMZZDIC="^ACM(41.1)",DIC("S")="I $D(@ACMZZDIC@(+Y,""AU"",""B"",DUZ)) ;IHS/CIM/LAB 12/23/06 FIX"

 D DIC K ACMZZDIC ;IHS/LAB 12/23/04 FIX

 I $E(X)=U!(X="")!(Y<1) S (XQUIT,ACMQUIT)="" K ACMRG,ACMRGNA Q

 S (DA,ACMRG)=+Y,ACMRGNA=$P(^ACM(41.1,ACMRG,0),U)

 D DECEASED(+Y) ;IHS/CIM/THL PATCH 5

 Q:$D(ACMTRN)

 I $D(ACMDELRG) S ACMRGTP="" Q

 I $D(ACMRGTP),'$D(ACMTRN) S (ACMEP,ACMES,ACMEP,ACMPP)="" D ^ACMCTRL Q

RGTP2 I '$D(ACMRGTP)&($D(ACMRGMGR)!$D(ACMRGUSR)) S DR=$S($D(ACMRGMGR):"[ACM REGISTER SETUP]",$D(ACMRGUSR):".05T",1:"") D:$D(ACMRGUSR) USER D  Q:'$D(^ACM(41.1,ACMRG,0))

 .I $D(ACMRGUSR),$D(ACMQUIT) Q

 .I DUZ'=$P($G(^ACM(41.1,ACMRG,4)),U) D SECMSG H 5 S ACMQUIT=1 Q

 .S ACMOLDN=$P($G(^ACM(41.1,ACMRG,0)),U)

 .D DIE

 .S ACMNEWN=$P($G(^ACM(41.1,ACMRG,0)),U)

 .D:ACMOLDN'=ACMNEWN NAMEREX

 I $D(ACMRGUSR),$D(ACMQUIT) K ACMQUIT G EN

 I $D(ACMRGCUS),'$D(ACMQUIT) D SLCT

 Q

SLCT F  D SELECT Q:$D(ACMQUIT)

 K ACMQUIT

 Q

SELECT D HEAD^ACMMENU

 W !!

 S ACMX="",ACMU1=0

 ;F ACMU1=1:1 S ACMX=$O(^ACM(56,"B",ACMX)) Q:ACMX=""  S ACMY=$O(^ACM(56,"B",ACMX,"")),ACMZ(ACMU1)=ACMY,ACMX(ACMU1)=ACMX

 F  S ACMX=$O(^ACM(56,"B",ACMX)) Q:ACMX=""  S ACMY=$O(^ACM(56,"B",ACMX,"")) I $P(^ACM(56,ACMY,0),U,4)'="D" S ACMU1=ACMU1+1,ACMZ(ACMU1)=ACMY,ACMX(ACMU1)=ACMX

 S ACMU11=ACMU1\2+(ACMU1#2)

 F ACM=1:1:ACMU11 D

 .S ACMU1=ACM,ACMY=ACMZ(ACMU1)

 .W !?10,$J(ACMU1,3)_")",?$X+2,ACMX(ACMU1)

 .I ACMX(ACMU1)["CASE REVIEW" W ?37,"<**"

 .E  I $D(^ACM(41.1,ACMRG,2,ACMY)) W ?37,"<=="

 .S ACMU1=ACM+ACMU11

 .;Q:'$D(ACMZ(ACMU1))  ;S ACMU1=ACMU1-1 Q

 .I '$D(ACMZ(ACMU1)) S ACMU1=ACMU1-1 Q

 .S ACMY=ACMZ(ACMU1)

 .W ?45,$J(ACMU1,3)_")",?$X+2,ACMX(ACMU1)

 .I ACMX(ACMU1)["REGISTER" W ?68,"<**"

 .E  I $D(^ACM(41.1,ACMRG,2,ACMY)) W ?68,"<=="

 S ACMU1=ACMU1+1

 I ACMU1#2 W !?10

 W ?45

 W $J(ACMU1,3)_")","  All data types"

 W !!,?12,"<** Indicates automatic selection of Register Component"

SLCT1 S DIR(0)="SOA^A:ADD;D:DELETE;H:HELP",DIR("A")="'A' to ADD, 'D' to DELETE option(s) or 'H' for HELP  ==> ",DIR("?")="Type 'A' to ADD, 'D' to DELETE 'H' for HELP "

 W !!

 D ^DIR K DIR

 I U[$E(X)!(X="") S ACMQUIT="" Q

 S ACMQK=Y

 I ACMQK="H" D ^ACMHELP Q

 W !!?10,"'<==' indicates option already selected for this register.",!?10,"To select several data types separate them with commas.",!?10,"For example:  ==> 1,3,7,9"

 K DR

 S:$E(ACMQK)="D" DR=".01///@"

 S DIR(0)="LOA^1:"_ACMU1,DIR("A")="Select option(s) ==> ",DIR("?")="Type a number from 1 to "_ACMU1

 W !

 D ^DIR K DIR

 I U[$E(X)!(X="") S ACMQUIT="" Q

 S ACMQK=Y

 S:$E(ACMQK,$L(ACMQK))="," ACMQK=$E(ACMQK,1,$L(ACMQK)-1)

 I ACMQK=ACMU1 D ALL Q

LOOP S ACMCNT=$L(ACMQK,","),ACMQK1=ACMQK

 W ! D WAIT^DICD W !

 F ACMLI=1:1:ACMCNT S ACMQK=$P(ACMQK1,",",ACMLI) D SET

 Q

SET Q:ACMQK>(ACMU1-1)

 ;Q:'$D(ACMZ(ACMQK))

 S (DA,X,DINUM)=ACMZ(ACMQK),DA(1)=ACMRG

 K DIC,DD S (DIE,DIC)="^ACM(41.1,"_ACMRG_",2,",DIC(0)="L"

 S:'$D(^ACM(41.1,ACMRG,2,0)) ^ACM(41.1,ACMRG,2,0)="^9002241.13P^^"

 I '$D(DR) K DD,DO D FILE^DICN K DIC,DD,DR

 D:$D(DR) DIE

 Q

 ;

ALL W ! D WAIT^DICD W !

 F ACMQK=1:1:(ACMU1-1) D SET

 Q

USER D HEAD^ACMMENU

 S ACMX="AUTHORIZED USERS"

 W !?80-$L(ACMX)\2,ACMX,!!

 S ACMX=""

 ;2ND SEC LEVEL

 S ACMRDEV=$P($G(^ACM(41.1,ACMRG,4)),U) ;IHS/CMI/TMJ PATCH #6

 I ACMRDEV'="" S ACMRDEV=$P($G(^VA(200,ACMRDEV,0)),U)

 I DUZ'=$P($G(^ACM(41.1,ACMRG,4)),U) W !!,$C(7),$C(7),?20,"You are NOT the Creator of this Register",!,?19,"Therefore, you cannot Add Users!",!!

 I DUZ'=$P($G(^ACM(41.1,ACMRG,4)),U) W !,"Contact the Register Developer- "_ACMRDEV_" -for more information.",!! H 5 S ACMQUIT=1 Q

 ;I DUZ'=$P($G(^ACM(41.1,ACMRG,4)),U) W !!!,$C(7),$C(7),?5,"You are NOT the Creator of this Register; therefore, you cannot Add Users!",!! H 5 S ACMQUIT=1 Q 

 F ACMU1=1:1 S ACMX=$O(^ACM(41.1,ACMRG,"AU","B",ACMX)) Q:ACMX=""  D USR1

 K ACMU1,ACMX,ACMY

 W !

 Q

USR1 Q:'$D(^VA(200,ACMX,0))

 S ACMY=$P(^VA(200,ACMX,0),U)

 I $D(ACMY) W:ACMU1#2=1 !?14 W:ACMU1#2=0 ?45 W ACMY

 Q

DIC W ! D ^DIC K DIC,DR,DD,DLAYGO Q

DIE D ^DIE K DIC,DIE,DA Q

SECMSG ;

 D SECMSG^ACMGTP1

 Q

NAMEREX ;

 D NAMEREX^ACMGTP1

 Q

DECEASED(ACMRGDA) ;PEP;PUBLISHED ENTRY POINT TO CHECK REGISTER PATIENTS FOR ;IHS/CIM/THL PATCH 5

 ;DECEASED STATUS

 ;ACMRGDA - IEN FOR THE REGISTER

 Q:'$G(ACMRGDA)

 Q:'$D(^ACM(41,"B",ACMRGDA))

 W !!,"Register being checked to update status of deceased patients."

 S ZTRTN="DEC1^ACMGTP"

 S ZTSAVE("ACM*")=""

 S ZTDTH=$H

 S ZTIO=""

 S ZTDESC="CHECK CMS REGISTER FOR DECEASED PATIENTS"

 D ^%ZTLOAD

 Q

DEC1 ;PEP;TO CHECK FOR DECEASED PATIENTS

 Q:'$G(ACMRGDA)

 N ACMDA,DFN

 S ACMDA=0

 F  S ACMDA=$O(^ACM(41,"B",ACMRGDA,ACMDA)) Q:'ACMDA  D

 .S DFN=$P($G(^ACM(41,ACMDA,0)),U,2)

 .Q:'$G(^DPT(+DFN,.35))

 .D DECEASED^ACMLPAT(DFN,ACMDA)

 Q

ACMGTP    ; IHS/TUCSON/TMJ - LOOKUP AND EDIT OF CMS REGISTER ; [ 02/10/2009  9:47 AM ]

 +1       ;;2.0;ACM CASE MANAGEMENT SYSTEM;**5,6,8**;JAN 10, 1996

 +2       ;PATCH #6 DISPLAYS REGISTER CREATOR TO NON-SECURED USER

EN        ;PEP - SELECT AND CREATE A REGISTER

 +1        DO RGTP

EXIT       KILL ACMU1,ACMU11,ACMX,ACMI,ACMJ,ACM,ACMQKI,ACMQK,ACMY,ACMRGCUS,ACMRGMGR,ACMRGUSR,ACMQUIT,ACMOLDN,ACMNEWN

 +1        KILL ACMQUIT,ACMZ

 +2        IF '$DATA(ACMRGTP)

               KILL ACMRG,ACMRGNA

 +3        QUIT 

RGTP      ;EP;TO SELECT AND CREATE A REGISTER

 +1        DO HEAD^ACMMENU

RGTPX     ;EP;SELECT/CREATE REG W/O HEADER

 +1        SET ACMX="REGISTER SELECTION UTILITY"

 +2        WRITE !!,?80-$LENGTH(ACMX)\2,ACMX,!

 +3        IF $DATA(ACMRGTP)

               KILL ACMRGMGR,ACMRGUSR,ACMRGCUS

 +4        IF $DATA(ACMRGMGR)

               KILL ACMRGTP,ACMRGUSR

 +5        IF $DATA(ACMRGUSR)

               KILL ACMRGMGR,ACMRGTP,ACMRGCUS

 +6        IF $DATA(ACMRGCUS)

               KILL ACMRGTP,ACMRGUSR

 +7        SET ACMRGX(3)="I '$D(^ACM(41.1,ACMRG,""AU"",""B"",DUZ)) S ACMJ=ACMJ-1"

           SET ACMRGX(4)="I $D(^ACM(41.1,ACMRG,""AU"",""B"",DUZ)) X ACMRGX(5)"

           SET ACMRGX(5)="W:ACMJ#2=1 !?14 W:ACMJ#2=0 ?45 W ACMRGX"

 +8        SET ACMRGX=""

 +9        FOR ACMJ=1:1

               SET ACMRGX=$ORDER(^ACM(41.1,"B",ACMRGX))

               IF ACMRGX=""

                   QUIT 

               DO RGTPA

 +10       KILL ACMRG,ACMRGX,ACMJ,ACMI

 +11       DO RGTP1

           DO EXIT

 +12       QUIT 

RGTPA      SET ACMRG=""

           SET ACMRG=$ORDER(^ACM(41.1,"B",ACMRGX,ACMRG))

 +1        IF $DATA(ACMRGTP)

               XECUTE ACMRGX(3)

 +2        IF $DATA(ACMRGTP)

               XECUTE ACMRGX(4)

 +3        IF '$DATA(ACMRGTP)

               XECUTE ACMRGX(5)

 +4        QUIT 

RGTP1      IF $DATA(ACMRGUSR)

               SET ACMRGUSR=DUZ

               SET DIC(0)="AEMQZ"

 +1        IF $DATA(ACMRGCUS)

               SET ACMRGCUS=DUZ

               SET DIC(0)="AEMQZ"

 +2        IF $DATA(ACMRGTP)

               SET DIC(0)="AEMQZ"

 +3        IF $DATA(ACMRGMGR)

               SET ACMRGMGR=DUZ

               SET DIC(0)="AELMQZ"

               SET DLAYGO=9002241

 +4        SET (DIC,DIE)="^ACM(41.1,"

           SET DIC("A")="    REGISTER: "

 +5        IF $DATA(ACMRGTP)

               SET ACMZZDIC="^ACM(41.1)"

               SET DIC("S")="I $D(@ACMZZDIC@(+Y,""AU"",""B"",DUZ)) ;IHS/CIM/LAB 12/23/06 FIX"

 +6       ;IHS/LAB 12/23/04 FIX

           DO DIC

           KILL ACMZZDIC

 +7        IF $EXTRACT(X)=U!(X="")!(Y<1)

               SET (XQUIT,ACMQUIT)=""

               KILL ACMRG,ACMRGNA

               QUIT 

 +8        SET (DA,ACMRG)=+Y

           SET ACMRGNA=$PIECE(^ACM(41.1,ACMRG,0),U)

 +9       ;IHS/CIM/THL PATCH 5

           DO DECEASED(+Y)

 +10       IF $DATA(ACMTRN)

               QUIT 

 +11       IF $DATA(ACMDELRG)

               SET ACMRGTP=""

               QUIT 

 +12       IF $DATA(ACMRGTP)

               IF '$DATA(ACMTRN)

                   SET (ACMEP,ACMES,ACMEP,ACMPP)=""

                   DO ^ACMCTRL

                   QUIT 

RGTP2      IF '$DATA(ACMRGTP)&($DATA(ACMRGMGR)!$DATA(ACMRGUSR))

               SET DR=$SELECT($DATA(ACMRGMGR):"[ACM REGISTER SETUP]",$DATA(ACMRGUSR):".05T",1:"")

               IF $DATA(ACMRGUSR)

                   DO USER

               Begin DoDot:1

 +1                IF $DATA(ACMRGUSR)

                       IF $DATA(ACMQUIT)

                           QUIT 

 +2                IF DUZ'=$PIECE($GET(^ACM(41.1,ACMRG,4)),U)

                       DO SECMSG

                       HANG 5

                       SET ACMQUIT=1

                       QUIT 

 +3                SET ACMOLDN=$PIECE($GET(^ACM(41.1,ACMRG,0)),U)

 +4                DO DIE

 +5                SET ACMNEWN=$PIECE($GET(^ACM(41.1,ACMRG,0)),U)

 +6                IF ACMOLDN'=ACMNEWN

                       DO NAMEREX

               End DoDot:1

               IF '$DATA(^ACM(41.1,ACMRG,0))

                   QUIT 

 +7        IF $DATA(ACMRGUSR)

               IF $DATA(ACMQUIT)

                   KILL ACMQUIT

                   GOTO EN

 +8        IF $DATA(ACMRGCUS)

               IF '$DATA(ACMQUIT)

                   DO SLCT

 +9        QUIT 

SLCT       FOR 

               DO SELECT

               IF $DATA(ACMQUIT)

                   QUIT 

 +1        KILL ACMQUIT

 +2        QUIT 

SELECT     DO HEAD^ACMMENU

 +1        WRITE !!

 +2        SET ACMX=""

           SET ACMU1=0

 +3       ;F ACMU1=1:1 S ACMX=$O(^ACM(56,"B",ACMX)) Q:ACMX=""  S ACMY=$O(^ACM(56,"B",ACMX,"")),ACMZ(ACMU1)=ACMY,ACMX(ACMU1)=ACMX

 +4        FOR 

               SET ACMX=$ORDER(^ACM(56,"B",ACMX))

               IF ACMX=""

                   QUIT 

               SET ACMY=$ORDER(^ACM(56,"B",ACMX,""))

               IF $PIECE(^ACM(56,ACMY,0),U,4)'="D"

                   SET ACMU1=ACMU1+1

                   SET ACMZ(ACMU1)=ACMY

                   SET ACMX(ACMU1)=ACMX

 +5        SET ACMU11=ACMU1\2+(ACMU1#2)

 +6        FOR ACM=1:1:ACMU11

               Begin DoDot:1

 +7                SET ACMU1=ACM

                   SET ACMY=ACMZ(ACMU1)

 +8                WRITE !?10,$JUSTIFY(ACMU1,3)_")",?$X+2,ACMX(ACMU1)

 +9                IF ACMX(ACMU1)["CASE REVIEW"

                       WRITE ?37,"<**"

 +10              IF '$TEST

                       IF $DATA(^ACM(41.1,ACMRG,2,ACMY))

                           WRITE ?37,"<=="

 +11               SET ACMU1=ACM+ACMU11

 +12      ;Q:'$D(ACMZ(ACMU1))  ;S ACMU1=ACMU1-1 Q

 +13               IF '$DATA(ACMZ(ACMU1))

                       SET ACMU1=ACMU1-1

                       QUIT 

 +14               SET ACMY=ACMZ(ACMU1)

 +15               WRITE ?45,$JUSTIFY(ACMU1,3)_")",?$X+2,ACMX(ACMU1)

 +16               IF ACMX(ACMU1)["REGISTER"

                       WRITE ?68,"<**"

 +17              IF '$TEST

                       IF $DATA(^ACM(41.1,ACMRG,2,ACMY))

                           WRITE ?68,"<=="

               End DoDot:1

 +18       SET ACMU1=ACMU1+1

 +19       IF ACMU1#2

               WRITE !?10

 +20       WRITE ?45

 +21       WRITE $JUSTIFY(ACMU1,3)_")","  All data types"

 +22       WRITE !!,?12,"<** Indicates automatic selection of Register Component"

SLCT1      SET DIR(0)="SOA^A:ADD;D:DELETE;H:HELP"

           SET DIR("A")="'A' to ADD, 'D' to DELETE option(s) or 'H' for HELP  ==> "

           SET DIR("?")="Type 'A' to ADD, 'D' to DELETE 'H' for HELP "

 +1        WRITE !!

 +2        DO ^DIR

           KILL DIR

 +3        IF U[$EXTRACT(X)!(X="")

               SET ACMQUIT=""

               QUIT 

 +4        SET ACMQK=Y

 +5        IF ACMQK="H"

               DO ^ACMHELP

               QUIT 

 +6        WRITE !!?10,"'<==' indicates option already selected for this register.",!?10,"To select several data types separate them with commas.",!?10,"For example:  ==> 1,3,7,9"

 +7        KILL DR

 +8        IF $EXTRACT(ACMQK)="D"

               SET DR=".01///@"

 +9        SET DIR(0)="LOA^1:"_ACMU1

           SET DIR("A")="Select option(s) ==> "

           SET DIR("?")="Type a number from 1 to "_ACMU1

 +10       WRITE !

 +11       DO ^DIR

           KILL DIR

 +12       IF U[$EXTRACT(X)!(X="")

               SET ACMQUIT=""

               QUIT 

 +13       SET ACMQK=Y

 +14       IF $EXTRACT(ACMQK,$LENGTH(ACMQK))=","

               SET ACMQK=$EXTRACT(ACMQK,1,$LENGTH(ACMQK)-1)

 +15       IF ACMQK=ACMU1

               DO ALL

               QUIT 

LOOP       SET ACMCNT=$LENGTH(ACMQK,",")

           SET ACMQK1=ACMQK

 +1        WRITE !

           DO WAIT^DICD

           WRITE !

 +2        FOR ACMLI=1:1:ACMCNT

               SET ACMQK=$PIECE(ACMQK1,",",ACMLI)

               DO SET

 +3        QUIT 

SET        IF ACMQK>(ACMU1-1)

               QUIT 

 +1       ;Q:'$D(ACMZ(ACMQK))

 +2        SET (DA,X,DINUM)=ACMZ(ACMQK)

           SET DA(1)=ACMRG

 +3        KILL DIC,DD

           SET (DIE,DIC)="^ACM(41.1,"_ACMRG_",2,"

           SET DIC(0)="L"

 +4        IF '$DATA(^ACM(41.1,ACMRG,2,0))

               SET ^ACM(41.1,ACMRG,2,0)="^9002241.13P^^"

 +5        IF '$DATA(DR)

               KILL DD,DO

               DO FILE^DICN

               KILL DIC,DD,DR

 +6        IF $DATA(DR)

               DO DIE

 +7        QUIT 

 +8       ;

ALL        WRITE !

           DO WAIT^DICD

           WRITE !

 +1        FOR ACMQK=1:1:(ACMU1-1)

               DO SET

 +2        QUIT 

USER       DO HEAD^ACMMENU

 +1        SET ACMX="AUTHORIZED USERS"

 +2        WRITE !?80-$LENGTH(ACMX)\2,ACMX,!!

 +3        SET ACMX=""

 +4       ;2ND SEC LEVEL

 +5       ;IHS/CMI/TMJ PATCH #6

           SET ACMRDEV=$PIECE($GET(^ACM(41.1,ACMRG,4)),U)

 +6        IF ACMRDEV'=""

               SET ACMRDEV=$PIECE($GET(^VA(200,ACMRDEV,0)),U)

 +7        IF DUZ'=$PIECE($GET(^ACM(41.1,ACMRG,4)),U)

               WRITE !!,$CHAR(7),$CHAR(7),?20,"You are NOT the Creator of this Register",!,?19,"Therefore, you cannot Add Users!",!!

 +8        IF DUZ'=$PIECE($GET(^ACM(41.1,ACMRG,4)),U)

               WRITE !,"Contact the Register Developer- "_ACMRDEV_" -for more information.",!!

               HANG 5

               SET ACMQUIT=1

               QUIT 

 +9       ;I DUZ'=$P($G(^ACM(41.1,ACMRG,4)),U) W !!!,$C(7),$C(7),?5,"You are NOT the Creator of this Register; therefore, you cannot Add Users!",!! H 5 S ACMQUIT=1 Q 

 +10       FOR ACMU1=1:1

               SET ACMX=$ORDER(^ACM(41.1,ACMRG,"AU","B",ACMX))

               IF ACMX=""

                   QUIT 

               DO USR1

 +11       KILL ACMU1,ACMX,ACMY

 +12       WRITE !

 +13       QUIT 

USR1       IF '$DATA(^VA(200,ACMX,0))

               QUIT 

 +1        SET ACMY=$PIECE(^VA(200,ACMX,0),U)

 +2        IF $DATA(ACMY)

               IF ACMU1#2=1

                   WRITE !?14

               IF ACMU1#2=0

                   WRITE ?45

               WRITE ACMY

 +3        QUIT 

DIC        WRITE !

           DO ^DIC

           KILL DIC,DR,DD,DLAYGO

           QUIT 

DIE        DO ^DIE

           KILL DIC,DIE,DA

           QUIT 

SECMSG    ;

 +1        DO SECMSG^ACMGTP1

 +2        QUIT 

NAMEREX   ;

 +1        DO NAMEREX^ACMGTP1

 +2        QUIT 

DECEASED(ACMRGDA) ;PEP;PUBLISHED ENTRY POINT TO CHECK REGISTER PATIENTS FOR ;IHS/CIM/THL PATCH 5

 +1       ;DECEASED STATUS

 +2       ;ACMRGDA - IEN FOR THE REGISTER

 +3        IF '$GET(ACMRGDA)

               QUIT 

 +4        IF '$DATA(^ACM(41,"B",ACMRGDA))

               QUIT 

 +5        WRITE !!,"Register being checked to update status of deceased patients."

 +6        SET ZTRTN="DEC1^ACMGTP"

 +7        SET ZTSAVE("ACM*")=""

 +8        SET ZTDTH=$HOROLOG

 +9        SET ZTIO=""

 +10       SET ZTDESC="CHECK CMS REGISTER FOR DECEASED PATIENTS"

 +11       DO ^%ZTLOAD

 +12       QUIT 

DEC1      ;PEP;TO CHECK FOR DECEASED PATIENTS

 +1        IF '$GET(ACMRGDA)

               QUIT 

 +2        NEW ACMDA,DFN

 +3        SET ACMDA=0

 +4        FOR 

               SET ACMDA=$ORDER(^ACM(41,"B",ACMRGDA,ACMDA))

               IF 'ACMDA

                   QUIT 

               Begin DoDot:1

 +5                SET DFN=$PIECE($GET(^ACM(41,ACMDA,0)),U,2)

 +6                IF '$GET(^DPT(+DFN,.35))

                       QUIT 

 +7                DO DECEASED^ACMLPAT(DFN,ACMDA)

               End DoDot:1

 +8        QUIT