ACMAPPT ; IHS/TUCSON/TMJ - EDIT OR DELETE AN APPOINTMENT ; [ 07/11/1999 7:38 PM ]
;;2.0;ACM CASE MANAGEMENT SYSTEM;*1*;JAN 10, 1996
;Patch #1 alows Edit of Existing Recall Data Date
;MAKE, DELETE OR CHANGE A RECALL DATE ENTRY
;CALLS ACMAPP1, NO INTERNAL ENTRY POINTS.
EN K ACMQUIT
D HEAD,CHOICE
I $D(ACMAPX) K ACMAPX G EN
I $D(ACMQUIT) D EXIT Q
D ADD:'$D(ACMQUIT)
D APPTDIE:'$D(ACMQUIT)&$D(DA)
D EXIT
G:'$D(ACMQUIT) EN
Q
;
ADD ;
S DIR(0)="9002249,.01",DIR("A")="Enter Date of Recall" K DA D ^DIR K DIR
Q:X="^"!(X="")
S X=Y
S DIC="^ACM(49,",DIC(0)="L",DIC("DR")=".02////"_ACMPTNO_";.03////"_ACMRGDFN_";.04////"_ACMRG
K DD,DO D FILE^DICN
S DA=+Y
D APPTDIE
Q
Q
HEAD D HEAD^ACMMENU
W !!?14,"Update ",@ACMRVON,"RECALL DATES",@ACMRVOFF,!?17,"for ",@ACMRVON,ACMPTNA2,@ACMRVOFF,!!?40,"NEXT APPT",?59,"REFERRAL",!?0,"NO.",?5,"RECALL DT",?17,"PURPOSE",?40,"DATE TIME",?59,"ORG/PROVIDER"
W !?0,"--- ---------",?15,"------------",?40,"-----------------",?59,"------------"
S (ACMA,ACMAA)="",ACMCREG1=""
F ACMCNT=1:1 S ACMA=$O(^ACM(49,"C",ACMPTNO,ACMA)) Q:'ACMA D LST
S ACMCNT=ACMCNT-1 K ACMCREG,ACMCREG1
Q
;
CHOICE S DIR(0)="SO^A:ADD"_$S(ACMCNT>0:";C:CHANGE;D:DELETE;E:EDIT DATE ONLY",1:""),DIR("A")=" Enter CHOICE",DIR("?")="Enter 'A', 'D', or 'C' or Press <RETURN> to Exit" ;IHS/CMI/LAB
D DIR
I U=$E(X)!(X="") S ACMQUIT="" S:U=$E(X) ACMOUT="" Q
S ACMX=Y
I ACMCNT>0,"CDE"[$E(ACMX) D DD S ACMAPX="" Q ;IHS/CMI/LAB
I ACMCNT<1,"A"'[$E(ACMX) W *7,!!?14,"??" S ACMAPX="" Q
Q
;
APPTDIE W !
S DIE="^ACM(49,",DR="11T;4T;5T;3T;7T;1T;2T"
I ACMX="C" S DA=$P(ACMCNT(ACMCNT1),U,3)
D DIE
S DIE="^ACM(41,",DA=ACMRGDFN,DR="11///TODAY"
D DIE
Q
;
APPTDT ;
;IHS/CMI/LAB - new subroutine patch 1
W !
S DIE="^ACM(49,",DR=".01"
I ACMX="E" S DA=$P(ACMCNT(ACMCNT1),U,3)
D DIE
S DIE="^ACM(41,",DA=ACMRGDFN,DR="11///TODAY"
D DIE
Q
EXIT K ACMA,ACM1,ACM2,ACMY,ACMZ,ACMZZ,ACMX,ACMCNT,ACMCNT1,ACMQUIT,ACMPV
Q
;
LST I '$D(^ACM(49,ACMA,"DT")) S ACMCNT=ACMCNT-1 Q
I $P(^ACM(49,ACMA,0),U,4)'=ACMRG S ACMCNT=ACMCNT-1 Q
S ACMAPP1=^ACM(49,ACMA,"DT"),ACMY=$P(ACMAPP1,U),ACMZ=$P(ACMAPP1,U,5),ACMZZ=$P(ACMAPP1,U,3),ACMPV=$P(ACMAPP1,U,4),ACM1=$P(^ACM(49,ACMA,0),U)
K ACMAPP1
I ACMY'="" S Y=ACMY X ^DD("DD") S ACMY=Y I 1
E S ACMY="NOT RECORDED"
I ACMZ'="" S ACMZ=$E(ACMZ,1,22)
E S ACMZ="NOT RECORDED"
I ACMZZ'="" S Y=ACMZZ X ^DD("DD") S ACMZZ=Y I 1
E S ACMZZ="NONE ON FILE"
I ACM1 S ACM2=^ACM(49,ACMA,0),ACM2=$E(ACM2,1,7)
E S ACM2="UNSPECIFIED"
S ACMCNT(ACMCNT)=ACMCNT_"^"_ACM2_"^"_ACMA_"^"_ACMZ,ACMCREG=$P(^ACM(41.1,$P(^ACM(49,ACMA,0),U,4),0),U)
I ACMCREG'=ACMCREG1 W ! S ACMCREG1=ACMCREG
I ACM2'="" S Y=ACM2 X ^DD("DD") S ACM2=Y
I ACMZZ'="" S ACMZZ=$E(ACMZZ,1,20)
W !,ACMCNT,?5,ACM2,?17,ACMZ,?40,ACMY,?58,ACMZZ
W !,?58,ACMPV
Q
;
DD S:ACMCNT=1 ACMCNT1=ACMCNT
DD1 I ACMCNT>1 D
.S DIR(0)="NO^1:"_ACMCNT,DIR("A")=$S(ACMX="D":"DELETE",ACMX="C":"CHANGE",ACMX="E":"EDIT DATE OF")_" WHICH RECALL DATE",DIR("?")="ENTER A NUMBER FROM 1 - "_ACMCNT
.D DIR
.S ACMCNT1=Y
Q:ACMCNT1["^"!(ACMCNT1="")
S ACM2=$P(ACMCNT(ACMCNT1),U,2),ACMA=$P(ACMCNT(ACMCNT1),U,3),ACMZ=$P(ACMCNT(ACMCNT1),U,4),ACMD=$S(ACMX="C":"APPTDIE",ACMX="D":"DELETE",ACMX="E":"APPTDT") ;IHS/CMI/LAB
S Y=ACM2 X ^DD("DD") S ACM3=Y ;Recall Date Conversion
W:ACMD="APPTDIE" !!?4,"RECALL DATE: ",ACM3," (PURPOSE: ",ACMZ,")"
W:ACMD="APPTDT" !!,?24,"RECALL DATE: ",ACM3," (PURPOSE): ",ACMZ,")",!,?6,"Enter a New Recall Date at Current Date Display" ;IHS/CMI/LAB
D @ACMD
K ACMD
Q
;
DELETE I $P(^ACM(49,ACMA,0),U,4)'=ACMRG W *7,!!?10,"You cannot delete appointments made by another register." H 2 Q
W !!,"DELETE ",@ACMRVON,ACM3,@ACMRVOFF," RECALL DATE FOR "
W @ACMRVON,ACMZ,@ACMRVOFF
S %=1 D YN^DICN
Q:%=-1!(%=2)!(%=0)
S DIE="^ACM(49,",DR=".01///@",DA=ACMA
D DIE
Q
;
DIR D ^DIR S:$D(DIRUT) ACMQUIT="" K DIR,DIRUT,DUOUT,DTOUT Q
DIE D ^DIE K DIC,DIE,DA,DR Q
ACMAPPT ; IHS/TUCSON/TMJ - EDIT OR DELETE AN APPOINTMENT ; [ 07/11/1999 7:38 PM ]
+1 ;;2.0;ACM CASE MANAGEMENT SYSTEM;*1*;JAN 10, 1996
+2 ;Patch #1 alows Edit of Existing Recall Data Date
+3 ;MAKE, DELETE OR CHANGE A RECALL DATE ENTRY
+4 ;CALLS ACMAPP1, NO INTERNAL ENTRY POINTS.
EN KILL ACMQUIT
+1 DO HEAD
DO CHOICE
+2 IF $DATA(ACMAPX)
KILL ACMAPX
GOTO EN
+3 IF $DATA(ACMQUIT)
DO EXIT
QUIT
+4 IF '$DATA(ACMQUIT)
DO ADD
+5 IF '$DATA(ACMQUIT)&$DATA(DA)
DO APPTDIE
+6 DO EXIT
+7 IF '$DATA(ACMQUIT)
GOTO EN
+8 QUIT
+9 ;
ADD ;
+1 SET DIR(0)="9002249,.01"
SET DIR("A")="Enter Date of Recall"
KILL DA
DO ^DIR
KILL DIR
+2 IF X="^"!(X="")
QUIT
+3 SET X=Y
+4 SET DIC="^ACM(49,"
SET DIC(0)="L"
SET DIC("DR")=".02////"_ACMPTNO_";.03////"_ACMRGDFN_";.04////"_ACMRG
+5 KILL DD,DO
DO FILE^DICN
+6 SET DA=+Y
+7 DO APPTDIE
+8 QUIT
+9 QUIT
HEAD DO HEAD^ACMMENU
+1 WRITE !!?14,"Update ",@ACMRVON,"RECALL DATES",@ACMRVOFF,!?17,"for ",@ACMRVON,ACMPTNA2,@ACMRVOFF,!!?40,"NEXT APPT",?59,"REFERRAL",!?0,"NO.",?5,"RECALL DT",?17,"PURPOSE",?40,"DATE TIME",?59,"ORG/PROVIDER"
+2 WRITE !?0,"--- ---------",?15,"------------",?40,"-----------------",?59,"------------"
+3 SET (ACMA,ACMAA)=""
SET ACMCREG1=""
+4 FOR ACMCNT=1:1
SET ACMA=$ORDER(^ACM(49,"C",ACMPTNO,ACMA))
IF 'ACMA
QUIT
DO LST
+5 SET ACMCNT=ACMCNT-1
KILL ACMCREG,ACMCREG1
+6 QUIT
+7 ;
CHOICE ;IHS/CMI/LAB
SET DIR(0)="SO^A:ADD"_$SELECT(ACMCNT>0:";C:CHANGE;D:DELETE;E:EDIT DATE ONLY",1:"")
SET DIR("A")=" Enter CHOICE"
SET DIR("?")="Enter 'A', 'D', or 'C' or Press <RETURN> to Exit"
+1 DO DIR
+2 IF U=$EXTRACT(X)!(X="")
SET ACMQUIT=""
IF U=$EXTRACT(X)
SET ACMOUT=""
QUIT
+3 SET ACMX=Y
+4 ;IHS/CMI/LAB
IF ACMCNT>0
IF "CDE"[$EXTRACT(ACMX)
DO DD
SET ACMAPX=""
QUIT
+5 IF ACMCNT<1
IF "A"'[$EXTRACT(ACMX)
WRITE *7,!!?14,"??"
SET ACMAPX=""
QUIT
+6 QUIT
+7 ;
APPTDIE WRITE !
+1 SET DIE="^ACM(49,"
SET DR="11T;4T;5T;3T;7T;1T;2T"
+2 IF ACMX="C"
SET DA=$PIECE(ACMCNT(ACMCNT1),U,3)
+3 DO DIE
+4 SET DIE="^ACM(41,"
SET DA=ACMRGDFN
SET DR="11///TODAY"
+5 DO DIE
+6 QUIT
+7 ;
APPTDT ;
+1 ;IHS/CMI/LAB - new subroutine patch 1
+2 WRITE !
+3 SET DIE="^ACM(49,"
SET DR=".01"
+4 IF ACMX="E"
SET DA=$PIECE(ACMCNT(ACMCNT1),U,3)
+5 DO DIE
+6 SET DIE="^ACM(41,"
SET DA=ACMRGDFN
SET DR="11///TODAY"
+7 DO DIE
+8 QUIT
EXIT KILL ACMA,ACM1,ACM2,ACMY,ACMZ,ACMZZ,ACMX,ACMCNT,ACMCNT1,ACMQUIT,ACMPV
+1 QUIT
+2 ;
LST IF '$DATA(^ACM(49,ACMA,"DT"))
SET ACMCNT=ACMCNT-1
QUIT
+1 IF $PIECE(^ACM(49,ACMA,0),U,4)'=ACMRG
SET ACMCNT=ACMCNT-1
QUIT
+2 SET ACMAPP1=^ACM(49,ACMA,"DT")
SET ACMY=$PIECE(ACMAPP1,U)
SET ACMZ=$PIECE(ACMAPP1,U,5)
SET ACMZZ=$PIECE(ACMAPP1,U,3)
SET ACMPV=$PIECE(ACMAPP1,U,4)
SET ACM1=$PIECE(^ACM(49,ACMA,0),U)
+3 KILL ACMAPP1
+4 IF ACMY'=""
SET Y=ACMY
XECUTE ^DD("DD")
SET ACMY=Y
IF 1
+5 IF '$TEST
SET ACMY="NOT RECORDED"
+6 IF ACMZ'=""
SET ACMZ=$EXTRACT(ACMZ,1,22)
+7 IF '$TEST
SET ACMZ="NOT RECORDED"
+8 IF ACMZZ'=""
SET Y=ACMZZ
XECUTE ^DD("DD")
SET ACMZZ=Y
IF 1
+9 IF '$TEST
SET ACMZZ="NONE ON FILE"
+10 IF ACM1
SET ACM2=^ACM(49,ACMA,0)
SET ACM2=$EXTRACT(ACM2,1,7)
+11 IF '$TEST
SET ACM2="UNSPECIFIED"
+12 SET ACMCNT(ACMCNT)=ACMCNT_"^"_ACM2_"^"_ACMA_"^"_ACMZ
SET ACMCREG=$PIECE(^ACM(41.1,$PIECE(^ACM(49,ACMA,0),U,4),0),U)
+13 IF ACMCREG'=ACMCREG1
WRITE !
SET ACMCREG1=ACMCREG
+14 IF ACM2'=""
SET Y=ACM2
XECUTE ^DD("DD")
SET ACM2=Y
+15 IF ACMZZ'=""
SET ACMZZ=$EXTRACT(ACMZZ,1,20)
+16 WRITE !,ACMCNT,?5,ACM2,?17,ACMZ,?40,ACMY,?58,ACMZZ
+17 WRITE !,?58,ACMPV
+18 QUIT
+19 ;
DD IF ACMCNT=1
SET ACMCNT1=ACMCNT
DD1 IF ACMCNT>1
Begin DoDot:1
+1 SET DIR(0)="NO^1:"_ACMCNT
SET DIR("A")=$SELECT(ACMX="D":"DELETE",ACMX="C":"CHANGE",ACMX="E":"EDIT DATE OF")_" WHICH RECALL DATE"
SET DIR("?")="ENTER A NUMBER FROM 1 - "_ACMCNT
+2 DO DIR
+3 SET ACMCNT1=Y
End DoDot:1
+4 IF ACMCNT1["^"!(ACMCNT1="")
QUIT
+5 ;IHS/CMI/LAB
SET ACM2=$PIECE(ACMCNT(ACMCNT1),U,2)
SET ACMA=$PIECE(ACMCNT(ACMCNT1),U,3)
SET ACMZ=$PIECE(ACMCNT(ACMCNT1),U,4)
SET ACMD=$SELECT(ACMX="C":"APPTDIE",ACMX="D":"DELETE",ACMX="E":"APPTDT")
+6 ;Recall Date Conversion
SET Y=ACM2
XECUTE ^DD("DD")
SET ACM3=Y
+7 IF ACMD="APPTDIE"
WRITE !!?4,"RECALL DATE: ",ACM3," (PURPOSE: ",ACMZ,")"
+8 ;IHS/CMI/LAB
IF ACMD="APPTDT"
WRITE !!,?24,"RECALL DATE: ",ACM3," (PURPOSE): ",ACMZ,")",!,?6,"Enter a New Recall Date at Current Date Display"
+9 DO @ACMD
+10 KILL ACMD
+11 QUIT
+12 ;
DELETE IF $PIECE(^ACM(49,ACMA,0),U,4)'=ACMRG
WRITE *7,!!?10,"You cannot delete appointments made by another register."
HANG 2
QUIT
+1 WRITE !!,"DELETE ",@ACMRVON,ACM3,@ACMRVOFF," RECALL DATE FOR "
+2 WRITE @ACMRVON,ACMZ,@ACMRVOFF
+3 SET %=1
DO YN^DICN
+4 IF %=-1!(%=2)!(%=0)
QUIT
+5 SET DIE="^ACM(49,"
SET DR=".01///@"
SET DA=ACMA
+6 DO DIE
+7 QUIT
+8 ;
DIR DO ^DIR
IF $DATA(DIRUT)
SET ACMQUIT=""
KILL DIR,DIRUT,DUOUT,DTOUT
QUIT
DIE DO ^DIE
KILL DIC,DIE,DA,DR
QUIT
