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
