SDRRCLR2 ;10N20/MAH- Recall Reminder ENTER EDIT 9/28/04
;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20
;;THIS ROUTINE WILL USE OPTION SDRR CARD ADD
STR ;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,KY,COMM
K ^TMP("SDRRCLR")
D ^DPTLK Q:Y<1
S DFN=+Y
I '$D(^SD(403.5,"B",DFN)) W !,"No Clinic Recall on file",! 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 ?1,"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
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
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
K DIC,DIE,DR,D0,DA,DLAYGO,NUM,PROV,X,Y,Z,OK,RDT,DIR
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
D QUIT
Q
QUIT K PROV,CLINIC,X,Y,C,D,ER,OK,DFN,FLAG,RS,KEY,KEYIFN,PROV1,PTN,RDT,DIR
K ^TMP("SDRRCLR",$J)
Q
SDRRCLR2 ;10N20/MAH- Recall Reminder ENTER EDIT 9/28/04
+1 ;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20
+2 ;;THIS ROUTINE WILL USE OPTION SDRR CARD ADD
STR ;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,KY,COMM
+2 KILL ^TMP("SDRRCLR")
+3 DO ^DPTLK
IF Y<1
QUIT
+4 SET DFN=+Y
+5 IF '$DATA(^SD(403.5,"B",DFN))
WRITE !,"No Clinic Recall on file",!
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 ?1,"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 IF ER
GOTO QUIT
+14 ;SD*561 convert lowercase to uppercase
XECUTE ^%ZOSF("UPPERCASE")
SET X=Y
+15 IF X["A"
GOTO NEW
+16 SET DA=$PIECE($GET(^TMP("SDRRCLR",$JOB,X)),"^",1)
IF DA=""
KILL DA,C,CLINIC,PROV,RDT
GOTO EN1
+17 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
+18 IF PROV1=""
QUIT
+19 IF KEY=""
QUIT
+20 NEW VALUE
+21 SET VALUE=$$LKUP^XPDKEY(KEY)
KILL KY
DO OWNSKEY^XUSRB(.KY,VALUE,DUZ)
+22 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
+23 QUIT
End DoDot:1
+24 IF FLAG=1
KILL FLAG
QUIT
+25 ;END OF NEW CHANGE
+26 GOTO UPDATE
+27 QUIT
+28 ;
+29 ;
NEW ;Adds new entry
+1 WRITE !!,"*Must have Recall Date,approved Recall Clinic,Recall Provider and Type of Recall"
+2 SET DIR(0)="Y"
SET DIR("A")="Do you have this information"
SET DIR("B")="NO"
DO ^DIR
IF Y'=1
GOTO QUIT
+3 SET (DIC,DIE)="^SD(403.5,"
SET DIC(0)="LZ"
SET X=DFN
SET DLAYGO=403.5
DO FILE^DICN
SET NUM=+Y
+4 SET DA=NUM
SET DR="[SDRR RECALL CARD ADD]"
SET DIE("NO^")="Not Allowed"
DO ^DIE
+5 KILL DIC,DIE,DR,D0,DA,DLAYGO,NUM,PROV,X,Y,Z,OK,RDT,DIR
+6 QUIT
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
+3 DO QUIT
+4 QUIT
QUIT KILL PROV,CLINIC,X,Y,C,D,ER,OK,DFN,FLAG,RS,KEY,KEYIFN,PROV1,PTN,RDT,DIR
+1 KILL ^TMP("SDRRCLR",$JOB)
+2 QUIT
