SDRR1 ;10N20/MAH ;RECALL REMINDER ENTER EDIT 7/28/04
;;5.3;Scheduling;**536,561,566,646**;Aug 13, 1993;Build 8
EN ;Entry point
;Tag STR will determine if the patient has already been enter into open access
;This routine is SDRRCLR EVENT protocol which is put on to SDAM MENU
;protocol
;This routine does not kill off DFN
STR(SDFN) ;Start checking entries in 403.5 if there is a "b" goes to update - if not goes to NEW
N I,Y,CLINIC,C,D,KEY,KY,COMM
S DFN=SDFN
I '$D(^SD(403.5,"B",DFN)) W !,"No Clinic Recall on file",! S DIR(0)="Y",DIR("A")="Are you sure you want to add a Recall entry ",DIR("B")="NO" D ^DIR I Y'=1 G QUIT
I $G(Y)>0 I '$D(^SD(403.5,"B",DFN)) G NEW
EN1 S C=0 F I=0:0 S I=$O(^SD(403.5,"B",DFN,I)) Q:'I I $D(^SD(403.5,I,0)) S D=^(0),C=C+1 S ^TMP("SDRRCLR",$J,C)=I_"^"_D
S (ER,OK)=0 W !,"CHOOSE FROM:" F I=0:0 S I=$O(^TMP("SDRRCLR",$J,I)) Q:'I S CLINIC=$P($G(^TMP("SDRRCLR",$J,I)),"^",3) D
.W !,$J(I,4),"> "
.I CLINIC'="" S CLINIC=$$GET1^DIQ(44,CLINIC_",",.01)
.I CLINIC="" S CLINIC="UNK. CLINIC"
.S PROV=$P($G(^TMP("SDRRCLR",$J,I)),"^",6) I PROV'="" S PROV=$P($G(^SD(403.54,PROV,0)),"^",1) I PROV'="" S PROV=$$NAME^XUSER(PROV,"F")
.I PROV="" S PROV="UNK. PROVIDER"
.S RDT=$P(^TMP("SDRRCLR",$J,I),"^",7) S Y=RDT D DD^%DT S RDT=Y
.S RS=$P(^TMP("SDRRCLR",$J,I),"^",11) S Y=RS D DD^%DT S RS=Y
.S COMM="",COMM=$P(^TMP("SDRRCLR",$J,I),"^",8)
.W "CLINIC:"_$E(CLINIC,1,15),?28," R/DATE:"_RDT,?53," NOTICE SENT:"_RS
.W !,?5,"PROVIDER:"_$E(PROV,1,20) S Z=I I $G(COMM)]"" W !,?5,$G(COMM) S Z=I
W !,"CHOOSE 1-",Z_" OR TYPE ""A"" TO ADD:" W:$D(^TMP("SDRRCLR",$J,I+1)) !,"OR '^' TO QUIT" W ": " R X:DTIME I $S('$T!(X["^"):1,X="":1,1:0) S ER=1 G QUIT
;CHECK PARAM IF NEEDED
G QUIT:ER
X ^%ZOSF("UPPERCASE") S X=Y ;SD*561 convert lowercase to uppercase
I X["A" G NEW
S DA=$P($G(^TMP("SDRRCLR",$J,X)),"^",1) I DA="" K DA,C,CLINIC,PROV,RDT G EN1
S (PROV1,KEY,FLAG)="" S PROV1=$P($G(^SD(403.5,DA,0)),"^",5) I PROV1'="" S KEY=$P($G(^SD(403.54,PROV1,0)),"^",7) D
.I PROV1="" Q
.I KEY="" Q
.N VALUE
.S VALUE=$$LKUP^XPDKEY(KEY) K KY D OWNSKEY^XUSRB(.KY,VALUE,DUZ)
.I $P(KY(0),"^",1)=0 W !,?25,"**YOU DO NOT HAVE ACCESS TO THIS ENTRY**",!,?12,"PLEASE CHECK WITH YOUR ADPAC OR IRM TO GET THE PROPER SECURITY KEY" R X:3 K KEY,PROV1 D QUIT S FLAG=1
.Q
I FLAG=1 K FLAG Q
;END OF NEW CHANGE
G UPDATE
Q
;
NEW ;Adds new entry
K DIC,DIR,DR,DIE,DO ;*646
W !!,"*Must have Recall Date,approved Recall Clinic,Recall Provider and Type of Recall"
S DIR(0)="Y",DIR("A")="Do you have this information",DIR("B")="NO" D ^DIR I Y'=1 G QUIT
S (DIC,DIE)="^SD(403.5,",DIC(0)="LZ",X=DFN,DLAYGO=403.5 D FILE^DICN S NUM=+Y
S DA=NUM,DR="[SDRR RECALL CARD ADD]",DIE("NO^")="Not Allowed" D ^DIE
I $D(DTOUT) D DELETE ;SD*566 if time out delete new incomplete record
K DIC,DIE,DR,D0,DA,DLAYGO,NUM,PROV,X,Y,Z,OK,RDT,CLINIC,RS,KEY,COMM,DIR
K DTOUT,^TMP("SDRRCLR",$J)
Q
;
DELETE ;SD*566 user timed out - delete new incomplete record & display message
S DIK=DIE
D ^DIK K DIK
W !!,*7,"*** ALL REQUIRED DATA WAS NOT ENTERED. ***",!,"*** RECALL REMINDER NOT CREATED FOR PATIENT: ",$P(^DPT(DFN,0),U,1),". ***"
Q
;
UPDATE ;Asks for new data
K DIC,DIE,DR S DIE="^SD(403.5,",DR="[SDRR RECALL CARD ADD]",DIE("NO^")="BACKOUTOK" D ^DIE
K DIC,DIE,DR,D0,DA,DLAYGO,NUM,PROV,X,Y,Z,OK,RDT,CLINIC,RS,KEY,COMM
D QUIT
Q
SDAM ;Entry Point for Appointment Management protocol
N ORACTION,ORVP,XQORQUIT,SDAMERR,SDCOAP,VALMY
S VALMBCK=""
D FULL^VALM1
I SDAMTYP="P" W !!,VALMHDR(1),! D STR(SDFN)
I SDAMTYP="C" D
.D EN^VALM2(XQORNOD(0))
.S SDCOAP=0 F S SDCOAP=$O(VALMY(SDCOAP)) Q:'SDCOAP D
..I $D(^TMP("SDAMIDX",$J,SDCOAP)) K SDAT S SDAT=^(SDCOAP) D
...W !!,^TMP("SDAM",$J,+SDAT,0),!
...D STR(+$P(SDAT,"^",2))
S VALMBCK="R"
QUIT K PROV,CLINIC,X,Y,C,D,ER,OK,PROV1,KEY,RS,FLAG,DIR,DFN,DIR
K ^TMP("SDRRCLR",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDRR1 3899 printed Dec 13, 2024@03:00:30 Page 2
SDRR1 ;10N20/MAH ;RECALL REMINDER ENTER EDIT 7/28/04
+1 ;;5.3;Scheduling;**536,561,566,646**;Aug 13, 1993;Build 8
EN ;Entry point
+1 ;Tag STR will determine if the patient has already been enter into open access
+2 ;This routine is SDRRCLR EVENT protocol which is put on to SDAM MENU
+3 ;protocol
+4 ;This routine does not kill off DFN
STR(SDFN) ;Start checking entries in 403.5 if there is a "b" goes to update - if not goes to NEW
+1 NEW I,Y,CLINIC,C,D,KEY,KY,COMM
+2 SET DFN=SDFN
+3 IF '$DATA(^SD(403.5,"B",DFN))
WRITE !,"No Clinic Recall on file",!
SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to add a Recall entry "
SET DIR("B")="NO"
DO ^DIR
IF Y'=1
GOTO QUIT
+4 IF $GET(Y)>0
IF '$DATA(^SD(403.5,"B",DFN))
GOTO NEW
EN1 SET C=0
FOR I=0:0
SET I=$ORDER(^SD(403.5,"B",DFN,I))
if 'I
QUIT
IF $DATA(^SD(403.5,I,0))
SET D=^(0)
SET C=C+1
SET ^TMP("SDRRCLR",$JOB,C)=I_"^"_D
+1 SET (ER,OK)=0
WRITE !,"CHOOSE FROM:"
FOR I=0:0
SET I=$ORDER(^TMP("SDRRCLR",$JOB,I))
if 'I
QUIT
SET CLINIC=$PIECE($GET(^TMP("SDRRCLR",$JOB,I)),"^",3)
Begin DoDot:1
+2 WRITE !,$JUSTIFY(I,4),"> "
+3 IF CLINIC'=""
SET CLINIC=$$GET1^DIQ(44,CLINIC_",",.01)
+4 IF CLINIC=""
SET CLINIC="UNK. CLINIC"
+5 SET PROV=$PIECE($GET(^TMP("SDRRCLR",$JOB,I)),"^",6)
IF PROV'=""
SET PROV=$PIECE($GET(^SD(403.54,PROV,0)),"^",1)
IF PROV'=""
SET PROV=$$NAME^XUSER(PROV,"F")
+6 IF PROV=""
SET PROV="UNK. PROVIDER"
+7 SET RDT=$PIECE(^TMP("SDRRCLR",$JOB,I),"^",7)
SET Y=RDT
DO DD^%DT
SET RDT=Y
+8 SET RS=$PIECE(^TMP("SDRRCLR",$JOB,I),"^",11)
SET Y=RS
DO DD^%DT
SET RS=Y
+9 SET COMM=""
SET COMM=$PIECE(^TMP("SDRRCLR",$JOB,I),"^",8)
+10 WRITE "CLINIC:"_$EXTRACT(CLINIC,1,15),?28," R/DATE:"_RDT,?53," NOTICE SENT:"_RS
+11 WRITE !,?5,"PROVIDER:"_$EXTRACT(PROV,1,20)
SET Z=I
IF $GET(COMM)]""
WRITE !,?5,$GET(COMM)
SET Z=I
End DoDot:1
+12 WRITE !,"CHOOSE 1-",Z_" OR TYPE ""A"" TO ADD:"
if $DATA(^TMP("SDRRCLR",$JOB,I+1))
WRITE !,"OR '^' TO QUIT"
WRITE ": "
READ X:DTIME
IF $SELECT('$TEST!(X["^"):1,X="":1,1:0)
SET ER=1
GOTO QUIT
+13 ;CHECK PARAM IF NEEDED
+14 if ER
GOTO QUIT
+15 ;SD*561 convert lowercase to uppercase
XECUTE ^%ZOSF("UPPERCASE")
SET X=Y
+16 IF X["A"
GOTO NEW
+17 SET DA=$PIECE($GET(^TMP("SDRRCLR",$JOB,X)),"^",1)
IF DA=""
KILL DA,C,CLINIC,PROV,RDT
GOTO EN1
+18 SET (PROV1,KEY,FLAG)=""
SET PROV1=$PIECE($GET(^SD(403.5,DA,0)),"^",5)
IF PROV1'=""
SET KEY=$PIECE($GET(^SD(403.54,PROV1,0)),"^",7)
Begin DoDot:1
+19 IF PROV1=""
QUIT
+20 IF KEY=""
QUIT
+21 NEW VALUE
+22 SET VALUE=$$LKUP^XPDKEY(KEY)
KILL KY
DO OWNSKEY^XUSRB(.KY,VALUE,DUZ)
+23 IF $PIECE(KY(0),"^",1)=0
WRITE !,?25,"**YOU DO NOT HAVE ACCESS TO THIS ENTRY**",!,?12,"PLEASE CHECK WITH YOUR ADPAC OR IRM TO GET THE PROPER SECURITY KEY"
READ X:3
KILL KEY,PROV1
DO QUIT
SET FLAG=1
+24 QUIT
End DoDot:1
+25 IF FLAG=1
KILL FLAG
QUIT
+26 ;END OF NEW CHANGE
+27 GOTO UPDATE
+28 QUIT
+29 ;
NEW ;Adds new entry
+1 ;*646
KILL DIC,DIR,DR,DIE,DO
+2 WRITE !!,"*Must have Recall Date,approved Recall Clinic,Recall Provider and Type of Recall"
+3 SET DIR(0)="Y"
SET DIR("A")="Do you have this information"
SET DIR("B")="NO"
DO ^DIR
IF Y'=1
GOTO QUIT
+4 SET (DIC,DIE)="^SD(403.5,"
SET DIC(0)="LZ"
SET X=DFN
SET DLAYGO=403.5
DO FILE^DICN
SET NUM=+Y
+5 SET DA=NUM
SET DR="[SDRR RECALL CARD ADD]"
SET DIE("NO^")="Not Allowed"
DO ^DIE
+6 ;SD*566 if time out delete new incomplete record
IF $DATA(DTOUT)
DO DELETE
+7 KILL DIC,DIE,DR,D0,DA,DLAYGO,NUM,PROV,X,Y,Z,OK,RDT,CLINIC,RS,KEY,COMM,DIR
+8 KILL DTOUT,^TMP("SDRRCLR",$JOB)
+9 QUIT
+10 ;
DELETE ;SD*566 user timed out - delete new incomplete record & display message
+1 SET DIK=DIE
+2 DO ^DIK
KILL DIK
+3 WRITE !!,*7,"*** ALL REQUIRED DATA WAS NOT ENTERED. ***",!,"*** RECALL REMINDER NOT CREATED FOR PATIENT: ",$PIECE(^DPT(DFN,0),U,1),". ***"
+4 QUIT
+5 ;
UPDATE ;Asks for new data
+1 KILL DIC,DIE,DR
SET DIE="^SD(403.5,"
SET DR="[SDRR RECALL CARD ADD]"
SET DIE("NO^")="BACKOUTOK"
DO ^DIE
+2 KILL DIC,DIE,DR,D0,DA,DLAYGO,NUM,PROV,X,Y,Z,OK,RDT,CLINIC,RS,KEY,COMM
+3 DO QUIT
+4 QUIT
SDAM ;Entry Point for Appointment Management protocol
+1 NEW ORACTION,ORVP,XQORQUIT,SDAMERR,SDCOAP,VALMY
+2 SET VALMBCK=""
+3 DO FULL^VALM1
+4 IF SDAMTYP="P"
WRITE !!,VALMHDR(1),!
DO STR(SDFN)
+5 IF SDAMTYP="C"
Begin DoDot:1
+6 DO EN^VALM2(XQORNOD(0))
+7 SET SDCOAP=0
FOR
SET SDCOAP=$ORDER(VALMY(SDCOAP))
if 'SDCOAP
QUIT
Begin DoDot:2
+8 IF $DATA(^TMP("SDAMIDX",$JOB,SDCOAP))
KILL SDAT
SET SDAT=^(SDCOAP)
Begin DoDot:3
+9 WRITE !!,^TMP("SDAM",$JOB,+SDAT,0),!
+10 DO STR(+$PIECE(SDAT,"^",2))
End DoDot:3
End DoDot:2
End DoDot:1
+11 SET VALMBCK="R"
QUIT KILL PROV,CLINIC,X,Y,C,D,ER,OK,PROV1,KEY,RS,FLAG,DIR,DFN,DIR
+1 KILL ^TMP("SDRRCLR",$JOB)
+2 QUIT
