- SDRRCLR2 ;10N20/MAH- Recall Reminder ENTER EDIT 9/28/04
- ;;5.3;Scheduling;**536,561,566**;Aug 13, 1993;Build 5
- ;;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")
- S DIC="^DPT(",DIC(0)="AEMQZ" D ^DIC ;SD*566 prohibit adding to file #2
- Q:$D(DTOUT)!($D(DUOUT)) ;SD*566
- 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
- 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,DIR,DTOUT
- Q
- ;
- DELETE ;SD*566 user timed out, delete new incomplete record and 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,DTOUT,DUOUT
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDRRCLR2 3204 printed Apr 23, 2025@19:15:15 Page 2
- SDRRCLR2 ;10N20/MAH- Recall Reminder ENTER EDIT 9/28/04
- +1 ;;5.3;Scheduling;**536,561,566**;Aug 13, 1993;Build 5
- +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 ;SD*566 prohibit adding to file #2
- SET DIC="^DPT("
- SET DIC(0)="AEMQZ"
- DO ^DIC
- +4 ;SD*566
- if $DATA(DTOUT)!($DATA(DUOUT))
- QUIT
- +5 if Y<1
- QUIT
- +6 SET DFN=+Y
- +7 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 ;SD*566 if time out delete new incomplete record
- IF $DATA(DTOUT)
- DO DELETE
- +6 KILL DIC,DIE,DR,D0,DA,DLAYGO,NUM,PROV,X,Y,Z,OK,RDT,DIR,DTOUT
- +7 QUIT
- +8 ;
- DELETE ;SD*566 user timed out, delete new incomplete record and 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,DTOUT,DUOUT
- +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
