- SDRR1 ;10N20/MAH ;RECALL REMINDER ENTER EDIT 7/28/04
- ;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20
- 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
- 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,CLINIC,RS,KEY,COMM,DIR
- K ^TMP("SDRRCLR",$J)
- 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
- SDRR1 ;10N20/MAH ;RECALL REMINDER ENTER EDIT 7/28/04
- +1 ;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20
- 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 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,CLINIC,RS,KEY,COMM,DIR
- +6 KILL ^TMP("SDRRCLR",$JOB)
- +7 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,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
