Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SDRRCLR

SDRRCLR.m

Go to the documentation of this file.
  1. SDRRCLR ;10N20/MAH/JLS - Reminder Recall CLEAN UP ;APR 08, 2016
  1. ;;5.3;Scheduling;**536,642,790**;Aug 13, 1993;Build 11
  1. ; Option: SDRR CLEAN-UP
  1. EN ;Entry point
  1. ;Will look at the "D" in file SD(403.5 - and loop through file 2
  1. ;to see if appt. has been made then delete entry in file 687065
  1. ;SDRRDA=IEN FOR FILE SD(403.5
  1. ;DFN= THE PATIENTS NUMBER
  1. ;REDT = RECALL DATE
  1. ;CLINIC = CLINIC ASSIGNED FOR THAT RECALL VISIT
  1. ;CLIN1 = CLINIC ASSIGN FOR THE APPT - IN FILE 2
  1. ;CK = APPT DATE IN FILE 2
  1. ;CK1 = IS THE APPT DATE MINUS TIME
  1. ;CAP = DIFFERENCE BETWEEN RECALL DATE AND APPT DATE - LOOKS AT -30 TO +30
  1. DIV Q:'$D(^SD(403.53,0))
  1. Q ;SD*5.3*790 - Decom Menu Option
  1. N SDCL,SDKF,SDRRCS,SDRRCRS ;alb/sat 642
  1. S CRP=0 F S CRP=$O(^SD(403.53,CRP)) Q:'CRP D
  1. . S PDT=$P($G(^SD(403.53,CRP,0)),"^",5) Q:PDT=""
  1. . S (CNT,SDRRDA)=1
  1. . F S CNT=$O(^SD(403.5,"D",CNT)) Q:CNT<1 D
  1. .. F S SDRRDA=$O(^SD(403.5,"D",CNT,SDRRDA)) Q:SDRRDA<1 D
  1. ...S PROV=$P($G(^SD(403.5,SDRRDA,0)),"^",5) Q:PROV=""
  1. ...S TEAM=$P($G(^SD(403.54,PROV,0)),"^",2) Q:TEAM=""
  1. ...S DIV=$P($G(^SD(403.55,TEAM,0)),"^",4) Q:DIV'=CRP
  1. ...S DFN=$P($G(^SD(403.5,SDRRDA,0)),"^",1) I DFN="" Q
  1. ...S CLINIC=$P($G(^SD(403.5,SDRRDA,0)),"^",2) I CLINIC="" Q
  1. ...S SDRRCS=$$GET1^DIQ(44,CLINIC_",",8,"I") S:SDRRCS'="" SDRRCS=$$GET1^DIQ(40.7,SDRRCS_",",1,"E") ;alb/sat 642
  1. ...S SDRRCRS=$$GET1^DIQ(44,CLINIC_",",2503,"I") S:SDRRCRS'="" SDRRCRS=$$GET1^DIQ(40.7,SDRRCRS_",",1,"E") ;alb/sat 642
  1. ...S REDT=$P($G(^SD(403.5,SDRRDA,0)),"^",6) I REDT="" Q
  1. ...D DEM^VADPT
  1. ...I $G(VADM(6),U)'="" S DA=SDRRDA,SDRRFTR=3,DIK="^SD(403.5," D ^DIK K DA,DIK Q
  1. ...N SDARRAY,SDCOUNT,SDDATE,SDAPPT,STATUS,APPT,CC,EDT,SDT
  1. ...S X1=REDT,X2=+PDT D C^%DTC S EDT=$P(X,".",1) K X,X1,X2
  1. ...S X1=REDT,X2=-PDT D C^%DTC S SDT=$P(X,".",1) K X,X1,X2
  1. ...S SDARRAY(1)=""_SDT_";"_EDT_""
  1. ...S:(SDRRCS="")&(SDRRCRS="") SDARRAY(2)=CLINIC ;alb/sat 642 SDAPI does not return based on stop code of CLINIC is passed in
  1. ...S SDARRAY(4)=DFN
  1. ...S SDARRAY("FLDS")="1;2;3;13;14" ;alb/sat 642 added 13,14
  1. ...S SDCOUNT=$$SDAPI^SDAMA301(.SDARRAY)
  1. ...I SDCOUNT>0 D
  1. ....S SDKF=0
  1. ....S SDDATE=0 F S SDDATE=$O(^TMP($J,"SDAMA301",DFN,CLINIC,SDDATE)) Q:SDDATE="" D Q:+SDKF
  1. .....S SDAPPT=$G(^TMP($J,"SDAMA301",DFN,CLINIC,SDDATE))
  1. .....S SDKF=$$PROCESS(DFN,CLINIC,SDAPPT,SDDATE,REDT,PDT,SDRRCS,SDRRCRS,SDRRDA) ;alb/sat 642 moved logic to tag PROCESS
  1. ....I 'SDKF S SDCL=0 F S SDCL=$O(^TMP($J,"SDAMA301",DFN,SDCL)) Q:SDCL="" D Q:+SDKF ;alb/sat 642
  1. .....S SDDATE=0 F S SDDATE=$O(^TMP($J,"SDAMA301",DFN,SDCL,SDDATE)) Q:SDDATE="" D Q:+SDKF
  1. ......S SDAPPT=$G(^TMP($J,"SDAMA301",DFN,SDCL,SDDATE))
  1. ......S SDKF=$$PROCESS(DFN,CLINIC,SDAPPT,SDDATE,REDT,PDT,SDRRCS,SDRRCRS,SDRRDA) ;alb/sat 642 moved logic to tag PROCESS
  1. ...I SDCOUNT<0 K ^TMP($J,"SDAMA301")
  1. ..Q
  1. QUIT K CNT,SDRRDA,DFN,CLINIC,CLIN1,REDT,CK,CK1,X,CAP,STATUS,PDT,TEAM,DIV,PROV,CRP,DEATH,SDRRFTR,VADM,^TMP($J,"SDAMA301")
  1. D KVAR^VADPT
  1. Q
  1. ;
  1. PROCESS(DFN,CLINIC,SDAPPT,SDDATE,REDT,PDT,SDRRCS,SDRRCRS,SDRRDA) ;alb/sat 642
  1. N APPT,CAP,CC,CK1,CLIN1,DA,DIK,SDAPPCST,SDAPPSTP,SDCS,SDCRS,SDKF,SDRRFTR,STATUS
  1. S SDKF=0
  1. S SDAPPSTP=$P($P(SDAPPT,U,13),";",2)
  1. S SDAPPCST=$P($P(SDAPPT,U,14),";",2)
  1. S STATUS=$P($G(SDAPPT),"^",3)
  1. S STATUS=$P(STATUS,";",1)
  1. I STATUS'="R" Q SDKF
  1. S APPT=$P(SDAPPT,"^",1)
  1. S CK1=$P(APPT,".",1)
  1. S CC=$P(SDAPPT,"^",2)
  1. S CLIN1=$P(CC,";",1)
  1. S CAP=$$FMDIFF^XLFDT(CK1,REDT)
  1. S SDCS=$S((SDAPPSTP="")&(SDRRCS=""):1,SDAPPSTP=SDRRCS:1,1:0) ;clinic stop
  1. S SDCRS=$S((SDAPPCST="")&(SDRRCRS=""):1,SDAPPCST=SDRRCRS:1,1:0) ;credit stop
  1. I CAP>-PDT,CAP<PDT I (CLIN1=CLINIC)!(SDCS&SDCRS) S DA=SDRRDA,SDRRFTR=7,DIK="^SD(403.5," D ^DIK K DA,DIK S SDKF=1
  1. Q SDKF