ACMLPAT ;cmi/anch/maw - LOOKUP FOR CMS CLIENTS ; [ 02/10/2009 9:42 AM ]
;;2.0;ACM CASE MANAGEMENT SYSTEM;**5,7,8**;JAN 10, 1996
;LOOKUP FOR CMS CLIENTS, INTERNAL ENTRY POINT: ADD
;PEP - LOOKUP CMS CLIENTS
EN Q:'$D(ACMRG)!$D(ACMQUIT)
D LOOKUP
D ^ACMLCMS:'$D(ACMQUIT)
Q
LOOKUP D HEAD^ACMMENU
I $P(^ACM(41.1,ACMRG,0),U,9)=1 W !!,*7,*7,"Patient lookup for the ",ACMRGNA,!,"is temporarily suspended during patient transfer." H 3 S ACMQUIT="ACMQUIT" Q
S ACMX="PATIENT LOOKUP UTILITY"
W !!?80-$L(ACMX)\2,ACMX,!!?15,"Select ",$S($D(ACMOUT):"another ",1:""),"CLIENT"
K ACMX,ACMOUT
;cmi/anch/maw 8/14/2007 removed I from DIC call patch 7
;S DIC="^ACM(41,",DIC(0)="AEIMQ",DIC("A")="NAME OR CHART: ",D="B^C",DIC("S")="I $D(^ACM(41,+Y)),$P(^ACM(41,+Y,0),U)=ACMRG"
S DIC="^ACM(41,",DIC(0)="AEMQ",DIC("A")="NAME OR CHART: ",D="B^C",DIC("S")="I $D(^ACM(41,+Y)),$P(^ACM(41,+Y,0),U)=ACMRG"
;cmi/anch/maw 8/14/2007 end of mods patch 7
W !
D MIX^DIC1
K DIC
I Y=-1&("^"[$E(X))!(X="") S ACMQUIT="ACMQUIT" Q
I Y=-1 D NEW G LOOKUP
S ACMPTNO=$P(^ACM(41,+Y,0),U,2),ACMPTNA=$P(^DPT(ACMPTNO,0),U),ACMPTNA2=$P($P(ACMPTNA,",",2)," ")_" "_$P(ACMPTNA,",")
I '$D(^ACM(41,"AC",ACMPTNO,ACMRG)) W !!?10,@ACMRVON,ACMPTNA2,@ACMRVOFF," is not on the ",ACMRGNA," register.",!?10,"You must add the patient before entering or printing data." H 3 G EN
S:'$D(ACMQUIT) ACMRGDFN=^ACM(41,"AC",ACMPTNO,ACMRG)
I $D(ACMPTDEL) D DELETE Q
D DECEASED(ACMPTNO,$G(ACMRGDFN)) ;IHS/CIM/THL PATCH 5
Q
NEW W !?14,"This CLIENT is not a registered patient.",!?14,"He/she must be registered before entry in the CMS."
S DIR(0)="EOA",DIR("A")="Press <ENTER> to continue..... "
D ^DIR K DIR
Q
ADD ;EP;TO ADD PATIENT TO A REGISTER
Q:'$D(ACMRG)
D HEAD^ACMMENU
W !!?14,"Add patient(s) to the ",ACMRGNA," register."
S DIC="^AUPNPAT(",DIC(0)="AEMQZ",DIC("A")="NAME, DOB OR CHART: "
D SET^AUPNLKZ
D ^AUPNLK
D RESET^AUPNLKZ
K DIC
I Y=-1&("^"[$E(X))!(X="") Q
I Y=-1 D NEW G ADD
S ACMPTNO=+Y,ACMPTNA=$P(^DPT(+Y,0),U),ACMPTNA2=$P($P(ACMPTNA,",",2)," ")_" "_$P(ACMPTNA,",")
I $D(^ACM(41,"AC",ACMPTNO,ACMRG)) W !!?14,ACMPTNA2," is already on the ",ACMRGNA," register." H 2 G ADD
W !!?17,"Add ",@ACMRVON,ACMPTNA2,@ACMRVOFF,!?14,"to the ",@ACMRVON,ACMRGNA,@ACMRVOFF," register"
S %=1
D YN^DICN
I %'=1 K ACMPTNO,ACMPTNA,ACMPTNA2 G ADD
K DIC,DD
S X=ACMRG,(DIE,DIC)="^ACM(41,",DIC(0)="L",DIC("DR")=".02////"_ACMPTNO_";1////A;2////"_DT_";4////"_DT
K DD,DO D FILE^DICN K DIC,DIE,DR,DA
D DECEASED(ACMPTNO,+Y) ;IHS/CIM/THL PATCH 5
W !!,"Edit data for ",ACMPTNA
S %=2
D YN^DICN
I %=1 S ACMRGDFN=^ACM(41,"AC",ACMPTNO,ACMRG) D ^ACMQK
G ADD
;
DELETE ;D DUPCHK Q:$D(ACMQUIT) ;TMJ 11/7/94
W !!?10,*7,*7,"****** WARNING ******",!!,"This procedure will delete ALL data for",!?12,@ACMRVON,ACMPTNA2,@ACMRVOFF," from the ",!?12,@ACMRVON,ACMRGNA,@ACMRVOFF," register.",!,"Are you certain you want to do this" S %=2 D YN^DICN
I %'=1 W !!,"No data deleted." H 1 S ACMQUIT="" Q
W !!,"Deletion of ",@ACMRVON,ACMPTNA2,@ACMRVOFF,!?3,"from the ",@ACMRVON,ACMRGNA,@ACMRVOFF," register..."
S ACMX=0,ACMGREF="^ACM(49)"
F S ACMX=$O(@ACMGREF@("AC",ACMRG,ACMPTNO,ACMX)) Q:'ACMX S DA=0 F S DA=$O(@ACMGREF@("AC",ACMRG,ACMPTNO,ACMX,DA)) Q:'DA S DIK="^ACM(49,",DA=DA D ^DIK K DIK,DIC
F ACMI=42,43,44,45,46,47,48,51,53,54,41 S ACMGREF="^ACM("_ACMI_")" F S ACMX=$O(@ACMGREF@("AC",ACMRG,ACMPTNO,ACMX)) Q:'ACMX S DIK="^ACM("_ACMI_",",DA=^(ACMX) D ^DIK W !,ACMI_" "_DA K DIK,DIC,DA
S DA=^ACM(41,"AC",ACMPTNO,ACMRG),DIK="^ACM(41,"
D ^DIK
K DIK,DIC,ACMGREF,ACMI,ACMX
W "is now complete."
S ACMQUIT=""
H 3
Q
DUPCHK N ACM
K ACMQUIT
S ACM=0
F S ACM=$O(^ACM(41,"C",ACMPTNO,ACM)) Q:'ACM I ^ACM(41,"AC",ACMPTNO,ACMRG)'=ACM S DA=ACM,DIK="^ACM(41," D ^DIK S ACMQUIT="",^ACM(41,"AC",ACMPTNO,ACMRG)=$O(^ACM(41,"C",ACMPTNO,""))
Q
DECEASED(DFN,DA) ;EP;TO SET STATUS TO DECEASED ;IHS/CIM/THL PATCH 5
Q:DFN<1!(DA<1)
Q:'$G(^DPT(DFN,.35))
S DIE="^ACM(41,"
S DR="1////D"
D ^DIE
K DA,DIE,DR
Q
ACMLPAT ;cmi/anch/maw - LOOKUP FOR CMS CLIENTS ; [ 02/10/2009 9:42 AM ]
+1 ;;2.0;ACM CASE MANAGEMENT SYSTEM;**5,7,8**;JAN 10, 1996
+2 ;LOOKUP FOR CMS CLIENTS, INTERNAL ENTRY POINT: ADD
+3 ;PEP - LOOKUP CMS CLIENTS
EN IF '$DATA(ACMRG)!$DATA(ACMQUIT)
QUIT
+1 DO LOOKUP
+2 IF '$DATA(ACMQUIT)
DO ^ACMLCMS
+3 QUIT
LOOKUP DO HEAD^ACMMENU
+1 IF $PIECE(^ACM(41.1,ACMRG,0),U,9)=1
WRITE !!,*7,*7,"Patient lookup for the ",ACMRGNA,!,"is temporarily suspended during patient transfer."
HANG 3
SET ACMQUIT="ACMQUIT"
QUIT
+2 SET ACMX="PATIENT LOOKUP UTILITY"
+3 WRITE !!?80-$LENGTH(ACMX)\2,ACMX,!!?15,"Select ",$SELECT($DATA(ACMOUT):"another ",1:""),"CLIENT"
+4 KILL ACMX,ACMOUT
+5 ;cmi/anch/maw 8/14/2007 removed I from DIC call patch 7
+6 ;S DIC="^ACM(41,",DIC(0)="AEIMQ",DIC("A")="NAME OR CHART: ",D="B^C",DIC("S")="I $D(^ACM(41,+Y)),$P(^ACM(41,+Y,0),U)=ACMRG"
+7 SET DIC="^ACM(41,"
SET DIC(0)="AEMQ"
SET DIC("A")="NAME OR CHART: "
SET D="B^C"
SET DIC("S")="I $D(^ACM(41,+Y)),$P(^ACM(41,+Y,0),U)=ACMRG"
+8 ;cmi/anch/maw 8/14/2007 end of mods patch 7
+9 WRITE !
+10 DO MIX^DIC1
+11 KILL DIC
+12 IF Y=-1&("^"[$EXTRACT(X))!(X="")
SET ACMQUIT="ACMQUIT"
QUIT
+13 IF Y=-1
DO NEW
GOTO LOOKUP
+14 SET ACMPTNO=$PIECE(^ACM(41,+Y,0),U,2)
SET ACMPTNA=$PIECE(^DPT(ACMPTNO,0),U)
SET ACMPTNA2=$PIECE($PIECE(ACMPTNA,",",2)," ")_" "_$PIECE(ACMPTNA,",")
+15 IF '$DATA(^ACM(41,"AC",ACMPTNO,ACMRG))
WRITE !!?10,@ACMRVON,ACMPTNA2,@ACMRVOFF," is not on the ",ACMRGNA," register.",!?10,"You must add the patient before entering or printing data."
HANG 3
GOTO EN
+16 IF '$DATA(ACMQUIT)
SET ACMRGDFN=^ACM(41,"AC",ACMPTNO,ACMRG)
+17 IF $DATA(ACMPTDEL)
DO DELETE
QUIT
+18 ;IHS/CIM/THL PATCH 5
DO DECEASED(ACMPTNO,$GET(ACMRGDFN))
+19 QUIT
NEW WRITE !?14,"This CLIENT is not a registered patient.",!?14,"He/she must be registered before entry in the CMS."
+1 SET DIR(0)="EOA"
SET DIR("A")="Press <ENTER> to continue..... "
+2 DO ^DIR
KILL DIR
+3 QUIT
ADD ;EP;TO ADD PATIENT TO A REGISTER
+1 IF '$DATA(ACMRG)
QUIT
+2 DO HEAD^ACMMENU
+3 WRITE !!?14,"Add patient(s) to the ",ACMRGNA," register."
+4 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQZ"
SET DIC("A")="NAME, DOB OR CHART: "
+5 DO SET^AUPNLKZ
+6 DO ^AUPNLK
+7 DO RESET^AUPNLKZ
+8 KILL DIC
+9 IF Y=-1&("^"[$EXTRACT(X))!(X="")
QUIT
+10 IF Y=-1
DO NEW
GOTO ADD
+11 SET ACMPTNO=+Y
SET ACMPTNA=$PIECE(^DPT(+Y,0),U)
SET ACMPTNA2=$PIECE($PIECE(ACMPTNA,",",2)," ")_" "_$PIECE(ACMPTNA,",")
+12 IF $DATA(^ACM(41,"AC",ACMPTNO,ACMRG))
WRITE !!?14,ACMPTNA2," is already on the ",ACMRGNA," register."
HANG 2
GOTO ADD
+13 WRITE !!?17,"Add ",@ACMRVON,ACMPTNA2,@ACMRVOFF,!?14,"to the ",@ACMRVON,ACMRGNA,@ACMRVOFF," register"
+14 SET %=1
+15 DO YN^DICN
+16 IF %'=1
KILL ACMPTNO,ACMPTNA,ACMPTNA2
GOTO ADD
+17 KILL DIC,DD
+18 SET X=ACMRG
SET (DIE,DIC)="^ACM(41,"
SET DIC(0)="L"
SET DIC("DR")=".02////"_ACMPTNO_";1////A;2////"_DT_";4////"_DT
+19 KILL DD,DO
DO FILE^DICN
KILL DIC,DIE,DR,DA
+20 ;IHS/CIM/THL PATCH 5
DO DECEASED(ACMPTNO,+Y)
+21 WRITE !!,"Edit data for ",ACMPTNA
+22 SET %=2
+23 DO YN^DICN
+24 IF %=1
SET ACMRGDFN=^ACM(41,"AC",ACMPTNO,ACMRG)
DO ^ACMQK
+25 GOTO ADD
+26 ;
DELETE ;D DUPCHK Q:$D(ACMQUIT) ;TMJ 11/7/94
+1 WRITE !!?10,*7,*7,"****** WARNING ******",!!,"This procedure will delete ALL data for",!?12,@ACMRVON,ACMPTNA2,@ACMRVOFF," from the ",!?12,@ACMRVON,ACMRGNA,@ACMRVOFF," register.",!,"Are you certain you want to do this"
SET %=2
DO YN^DICN
+2 IF %'=1
WRITE !!,"No data deleted."
HANG 1
SET ACMQUIT=""
QUIT
+3 WRITE !!,"Deletion of ",@ACMRVON,ACMPTNA2,@ACMRVOFF,!?3,"from the ",@ACMRVON,ACMRGNA,@ACMRVOFF," register..."
+4 SET ACMX=0
SET ACMGREF="^ACM(49)"
+5 FOR
SET ACMX=$ORDER(@ACMGREF@("AC",ACMRG,ACMPTNO,ACMX))
IF 'ACMX
QUIT
SET DA=0
FOR
SET DA=$ORDER(@ACMGREF@("AC",ACMRG,ACMPTNO,ACMX,DA))
IF 'DA
QUIT
SET DIK="^ACM(49,"
SET DA=DA
DO ^DIK
KILL DIK,DIC
+6 FOR ACMI=42,43,44,45,46,47,48,51,53,54,41
SET ACMGREF="^ACM("_ACMI_")"
FOR
SET ACMX=$ORDER(@ACMGREF@("AC",ACMRG,ACMPTNO,ACMX))
IF 'ACMX
QUIT
SET DIK="^ACM("_ACMI_","
SET DA=^(ACMX)
DO ^DIK
WRITE !,ACMI_" "_DA
KILL DIK,DIC,DA
+7 SET DA=^ACM(41,"AC",ACMPTNO,ACMRG)
SET DIK="^ACM(41,"
+8 DO ^DIK
+9 KILL DIK,DIC,ACMGREF,ACMI,ACMX
+10 WRITE "is now complete."
+11 SET ACMQUIT=""
+12 HANG 3
+13 QUIT
DUPCHK NEW ACM
+1 KILL ACMQUIT
+2 SET ACM=0
+3 FOR
SET ACM=$ORDER(^ACM(41,"C",ACMPTNO,ACM))
IF 'ACM
QUIT
IF ^ACM(41,"AC",ACMPTNO,ACMRG)'=ACM
SET DA=ACM
SET DIK="^ACM(41,"
DO ^DIK
SET ACMQUIT=""
SET ^ACM(41,"AC",ACMPTNO,ACMRG)=$ORDER(^ACM(41,"C",ACMPTNO,""))
+4 QUIT
DECEASED(DFN,DA) ;EP;TO SET STATUS TO DECEASED ;IHS/CIM/THL PATCH 5
+1 IF DFN<1!(DA<1)
QUIT
+2 IF '$GET(^DPT(DFN,.35))
QUIT
+3 SET DIE="^ACM(41,"
+4 SET DR="1////D"
+5 DO ^DIE
+6 KILL DA,DIE,DR
+7 QUIT
