ACMAPPT.m

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