ACMAPP1.m

ACMAPP1 ; IHS/TUCSON/TMJ - ACMAPPT SUBROUTINE LISTS CURRENT APPTS ; [ 01/24/96  10:37 AM ]

 ;;2.0;ACM CASE MANAGEMENT SYSTEM;;JAN 10, 1996

 ;FINDS RESOURCE, CHECKS FOR RELATED SERVICE, ADDS NEW SERVICE AND/OR

 ;APPOINTMENTS, CALLED BY ACMAPPT, NO INTERNAL ENTRY POINTS

EN D PRO K ACMSCNO

 D TEST:'$D(ACMQUIT)

 I '$D(ACMQUIT),$D(ACMSCNO) D CHK,EXIT Q

 D SVC:'$D(ACMQUIT) K DA

 D CHK:'$D(ACMQUIT)

 D EXIT

 Q

 ;

PRO K ACMQUIT

 S DIC="^ACM(50,",DIC(0)="AEMQ",DIC("A")="    RESOURCE: "

 S DIC("S")="I $D(^ACM(50,+Y,""RG"",""B"",ACMRG))"

 W ! D ^DIC K DIC

 I X=""!($E(X)=U)!(Y=-1) S ACMQUIT="" Q

 S ACMCLNO=+Y,ACMCLNA=$P(^ACM(50,ACMCLNO,0),U)

 Q

 ;

SVC K DIC,DD

 S DIC="^ACM(47.1,"

 S DIC(0)="AEMQ"

 S DIC("A")="     SERVICE: "

 S DIC("S")="I $D(^ACM(50,ACMCLNO,2,""B"",Y))"

 W ! D ^DIC K DIC,DD

 I X=U S ACMQUIT="" Q

 I Y=-1 W !!?10,"Enter the RELATED SERVICE for the appointment.",! G SVC

 S ACMSCNO=+Y,ACMSCNA=$P(Y,U,2)

 Q

 ;

EXIT K ACMU,%Y,ACMCLNO,ACMCLNA,ACMSVNO,ACMSVNA,ACMSCNA,ACMSCNO,ACMQUIT

 Q

 ;

CHK I '$D(^ACM(47.1,ACMSCNO,"RG","B",ACMRG)) D SVMESS

 S ACMU="" F ACMI=0:0 S ACMU=$O(^ACM(47,"AC",ACMRG,ACMPTNO,ACMU)) Q:'ACMU  S ACMUA=^(ACMU) I +^ACM(47,ACMUA,0)=ACMSCNO S ACMSVNO=ACMUA Q

 I $D(ACMSVNO) D CHKS Q

 D ADDSERV

 D NEW:'$D(ACMQUIT)

 Q

 ;

CHKS S:'$D(^ACM(47,ACMSVNO,"DT")) ^ACM(47,ACMSVNO,"DT")="E"

 I $P(^ACM(47,ACMSVNO,"DT"),U)'="E" D STAT Q:$D(ACMQUIT)

 S ACMU=0 F ACMI=0:0 S ACMU=$O(^ACM(49,"C",ACMPTNO,ACMU)) Q:'ACMU  I $P(^ACM(49,ACMU,"DT"),U,5)=ACMSCNO D WANTNEW Q

 I $D(ACMNONU) K ACMNONU Q

 D NEW

 Q

 ;

SVMESS S:'$D(^ACM(47.1,ACMSCNO,"RG")) ^ACM(47.1,ACMSCNO,"RG",0)="^9002247.12P^^"

 S DIC="^ACM(47.1,DA(1),""RG"",",X=ACMRG,DIC(0)="L",DA(1)=ACMSCNO

 K DD,DO D FILE^DICN Q

 W !!?10,"The ",@ACMRVON,ACMRGNA,@ACMRVOFF," register is not associated with"

 W !?10,"the ",@ACMRVON,ACMSCNA,@ACMRVOFF," service."

 W !?10,"The ",ACMRGNA," register must be added for this service."

 W !?10,"Use the 'Supporting Data' Option from the MAIN MENU."

 W !!?10,"Strike <CR> to continue." R ACMX:DTIME

 Q

 ;

WANTNEW W !!?10,"Do you want to add another appointment for this service"

 S %=1 D YN^DICN

 I %=-1!($E(%Y)="N") S ACMNONU="" Q

 Q

 ;

ADDSERV W !!?10,@ACMRVON,ACMPTNA2,@ACMRVOFF," is not signed up for"

 W !?10,@ACMRVON,ACMSCNA,@ACMRVOFF,"."

 W !!?10,"Want to enroll him/her for ",ACMSCNA S %=1 D YN^DICN

 I %Y["^" S ACMQUIT="" Q

 I %'=1 W !!?10,"CLIENT must be ENROLLED in the SERVICE before he/she",!?10,"can get an appointment to this provider.  If you want to",!?10,"escape without enrolling this CLIENT, type '^' followed by a <CR>." G ADDSERV

 K DIC,DD S DIC="^ACM(47,",DIC(0)="L",X=ACMSCNO

 S DIC("DR")=".02////"_ACMPTNO_";.03////"_ACMRGDFN_";.04////"_ACMRG

 K DD,DO D FILE^DICN K DIC,DR,DD

 S DIE="^ACM(47,",(DA,ACMSVNO)=+Y,DR="1///E" D DIE1

 Q

 ;

DIE1 D ^DIE K DIC,DIE,DR

 S DIE="^ACM(41,",DA=ACMRGDFN,DR="11///TODAY" D ^DIE K DIC,DIE,DR

 Q

 ;

STAT W !!?10,"This CLIENT is signed up for ",@ACMRVON,ACMSCNA,@ACMRVOFF

 W !?10,"but his/her status is not indicated as being ENROLLED."

 W !?10,"Want to change the status to ENROLLED"

 S %=1 D YN^DICN

 I %'=1 W !!?10,"CLIENT must be ENROLLED for ",ACMSCNA,!?10," before he/she can get an appointment for this service.",!?10,"If you want to escape without enrolling this CLIENT, type '^' followed by a <CR>." G STAT

 S DA=ACMSVNO,DR="1///E",DIE="^ACM(47," D DIE1

 Q

 ;

NEW W !!?10,"I will add the following appointment for this client =>"

 W !!?14,"Provider: ",@ACMRVON,ACMCLNA,@ACMRVOFF

 W !?15,"Service: ",@ACMRVON,ACMSCNA,@ACMRVOFF

 W !!?10,"OK" S %=1 D YN^DICN

 I %'=1 S ACMQUIT="" K DA Q

 S X=ACMCLNO

 K DIC,DD

 S DIC="^ACM(49,",DIC(0)="L"

 S DIC("DR")=".02////"_ACMPTNO_";.03////"_ACMRGDFN_";.04////"_ACMRG_";11////"_ACMSCNO

 W ! D WAIT^DICD W !

 K DD,DO D FILE^DICN S DA=+Y K DIC,DR,DD

 Q

 ;

TEST S ACMU="" F ACMI=1:1 S ACMU=$O(^ACM(50,ACMCLNO,2,ACMU)) Q:'ACMU  S X=^(ACMU,0) S:ACMI=1 ACMSCNO=X,ACMSCNA=$P(^ACM(47.1,X,0),U) I ACMI>1 Q

 I ACMI=1 Q

 K ACMSCNO,ACMSCNA

 Q

 ;

ACMAPP1   ; IHS/TUCSON/TMJ - ACMAPPT SUBROUTINE LISTS CURRENT APPTS ; [ 01/24/96  10:37 AM ]

 +1       ;;2.0;ACM CASE MANAGEMENT SYSTEM;;JAN 10, 1996

 +2       ;FINDS RESOURCE, CHECKS FOR RELATED SERVICE, ADDS NEW SERVICE AND/OR

 +3       ;APPOINTMENTS, CALLED BY ACMAPPT, NO INTERNAL ENTRY POINTS

EN         DO PRO

           KILL ACMSCNO

 +1        IF '$DATA(ACMQUIT)

               DO TEST

 +2        IF '$DATA(ACMQUIT)

               IF $DATA(ACMSCNO)

                   DO CHK

                   DO EXIT

                   QUIT 

 +3        IF '$DATA(ACMQUIT)

               DO SVC

           KILL DA

 +4        IF '$DATA(ACMQUIT)

               DO CHK

 +5        DO EXIT

 +6        QUIT 

 +7       ;

PRO        KILL ACMQUIT

 +1        SET DIC="^ACM(50,"

           SET DIC(0)="AEMQ"

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

 +2        SET DIC("S")="I $D(^ACM(50,+Y,""RG"",""B"",ACMRG))"

 +3        WRITE !

           DO ^DIC

           KILL DIC

 +4        IF X=""!($EXTRACT(X)=U)!(Y=-1)

               SET ACMQUIT=""

               QUIT 

 +5        SET ACMCLNO=+Y

           SET ACMCLNA=$PIECE(^ACM(50,ACMCLNO,0),U)

 +6        QUIT 

 +7       ;

SVC        KILL DIC,DD

 +1        SET DIC="^ACM(47.1,"

 +2        SET DIC(0)="AEMQ"

 +3        SET DIC("A")="     SERVICE: "

 +4        SET DIC("S")="I $D(^ACM(50,ACMCLNO,2,""B"",Y))"

 +5        WRITE !

           DO ^DIC

           KILL DIC,DD

 +6        IF X=U

               SET ACMQUIT=""

               QUIT 

 +7        IF Y=-1

               WRITE !!?10,"Enter the RELATED SERVICE for the appointment.",!

               GOTO SVC

 +8        SET ACMSCNO=+Y

           SET ACMSCNA=$PIECE(Y,U,2)

 +9        QUIT 

 +10      ;

EXIT       KILL ACMU,%Y,ACMCLNO,ACMCLNA,ACMSVNO,ACMSVNA,ACMSCNA,ACMSCNO,ACMQUIT

 +1        QUIT 

 +2       ;

CHK        IF '$DATA(^ACM(47.1,ACMSCNO,"RG","B",ACMRG))

               DO SVMESS

 +1        SET ACMU=""

           FOR ACMI=0:0

               SET ACMU=$ORDER(^ACM(47,"AC",ACMRG,ACMPTNO,ACMU))

               IF 'ACMU

                   QUIT 

               SET ACMUA=^(ACMU)

               IF +^ACM(47,ACMUA,0)=ACMSCNO

                   SET ACMSVNO=ACMUA

                   QUIT 

 +2        IF $DATA(ACMSVNO)

               DO CHKS

               QUIT 

 +3        DO ADDSERV

 +4        IF '$DATA(ACMQUIT)

               DO NEW

 +5        QUIT 

 +6       ;

CHKS       IF '$DATA(^ACM(47,ACMSVNO,"DT"))

               SET ^ACM(47,ACMSVNO,"DT")="E"

 +1        IF $PIECE(^ACM(47,ACMSVNO,"DT"),U)'="E"

               DO STAT

               IF $DATA(ACMQUIT)

                   QUIT 

 +2        SET ACMU=0

           FOR ACMI=0:0

               SET ACMU=$ORDER(^ACM(49,"C",ACMPTNO,ACMU))

               IF 'ACMU

                   QUIT 

               IF $PIECE(^ACM(49,ACMU,"DT"),U,5)=ACMSCNO

                   DO WANTNEW

                   QUIT 

 +3        IF $DATA(ACMNONU)

               KILL ACMNONU

               QUIT 

 +4        DO NEW

 +5        QUIT 

 +6       ;

SVMESS     IF '$DATA(^ACM(47.1,ACMSCNO,"RG"))

               SET ^ACM(47.1,ACMSCNO,"RG",0)="^9002247.12P^^"

 +1        SET DIC="^ACM(47.1,DA(1),""RG"","

           SET X=ACMRG

           SET DIC(0)="L"

           SET DA(1)=ACMSCNO

 +2        KILL DD,DO

           DO FILE^DICN

           QUIT 

 +3        WRITE !!?10,"The ",@ACMRVON,ACMRGNA,@ACMRVOFF," register is not associated with"

 +4        WRITE !?10,"the ",@ACMRVON,ACMSCNA,@ACMRVOFF," service."

 +5        WRITE !?10,"The ",ACMRGNA," register must be added for this service."

 +6        WRITE !?10,"Use the 'Supporting Data' Option from the MAIN MENU."

 +7        WRITE !!?10,"Strike <CR> to continue."

           READ ACMX:DTIME

 +8        QUIT 

 +9       ;

WANTNEW    WRITE !!?10,"Do you want to add another appointment for this service"

 +1        SET %=1

           DO YN^DICN

 +2        IF %=-1!($EXTRACT(%Y)="N")

               SET ACMNONU=""

               QUIT 

 +3        QUIT 

 +4       ;

ADDSERV    WRITE !!?10,@ACMRVON,ACMPTNA2,@ACMRVOFF," is not signed up for"

 +1        WRITE !?10,@ACMRVON,ACMSCNA,@ACMRVOFF,"."

 +2        WRITE !!?10,"Want to enroll him/her for ",ACMSCNA

           SET %=1

           DO YN^DICN

 +3        IF %Y["^"

               SET ACMQUIT=""

               QUIT 

 +4        IF %'=1

               WRITE !!?10,"CLIENT must be ENROLLED in the SERVICE before he/she",!?10,"can get an appointment to this provider.  If you want to",!?10,"escape without enrolling this CLIENT, type '^' followed by a <CR>."

               GOTO ADDSERV

 +5        KILL DIC,DD

           SET DIC="^ACM(47,"

           SET DIC(0)="L"

           SET X=ACMSCNO

 +6        SET DIC("DR")=".02////"_ACMPTNO_";.03////"_ACMRGDFN_";.04////"_ACMRG

 +7        KILL DD,DO

           DO FILE^DICN

           KILL DIC,DR,DD

 +8        SET DIE="^ACM(47,"

           SET (DA,ACMSVNO)=+Y

           SET DR="1///E"

           DO DIE1

 +9        QUIT 

 +10      ;

DIE1       DO ^DIE

           KILL DIC,DIE,DR

 +1        SET DIE="^ACM(41,"

           SET DA=ACMRGDFN

           SET DR="11///TODAY"

           DO ^DIE

           KILL DIC,DIE,DR

 +2        QUIT 

 +3       ;

STAT       WRITE !!?10,"This CLIENT is signed up for ",@ACMRVON,ACMSCNA,@ACMRVOFF

 +1        WRITE !?10,"but his/her status is not indicated as being ENROLLED."

 +2        WRITE !?10,"Want to change the status to ENROLLED"

 +3        SET %=1

           DO YN^DICN

 +4        IF %'=1

               WRITE !!?10,"CLIENT must be ENROLLED for ",ACMSCNA,!?10," before he/she can get an appointment for this service.",!?10,"If you want to escape without enrolling this CLIENT, type '^' followed by a <CR>."

               GOTO STAT

 +5        SET DA=ACMSVNO

           SET DR="1///E"

           SET DIE="^ACM(47,"

           DO DIE1

 +6        QUIT 

 +7       ;

NEW        WRITE !!?10,"I will add the following appointment for this client =>"

 +1        WRITE !!?14,"Provider: ",@ACMRVON,ACMCLNA,@ACMRVOFF

 +2        WRITE !?15,"Service: ",@ACMRVON,ACMSCNA,@ACMRVOFF

 +3        WRITE !!?10,"OK"

           SET %=1

           DO YN^DICN

 +4        IF %'=1

               SET ACMQUIT=""

               KILL DA

               QUIT 

 +5        SET X=ACMCLNO

 +6        KILL DIC,DD

 +7        SET DIC="^ACM(49,"

           SET DIC(0)="L"

 +8        SET DIC("DR")=".02////"_ACMPTNO_";.03////"_ACMRGDFN_";.04////"_ACMRG_";11////"_ACMSCNO

 +9        WRITE !

           DO WAIT^DICD

           WRITE !

 +10       KILL DD,DO

           DO FILE^DICN

           SET DA=+Y

           KILL DIC,DR,DD

 +11       QUIT 

 +12      ;

TEST       SET ACMU=""

           FOR ACMI=1:1

               SET ACMU=$ORDER(^ACM(50,ACMCLNO,2,ACMU))

               IF 'ACMU

                   QUIT 

               SET X=^(ACMU,0)

               IF ACMI=1

                   SET ACMSCNO=X

                   SET ACMSCNA=$PIECE(^ACM(47.1,X,0),U)

               IF ACMI>1

                   QUIT 

 +1        IF ACMI=1

               QUIT 

 +2        KILL ACMSCNO,ACMSCNA

 +3        QUIT 

 +4       ;