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 ;
