- SDRRCLR ;10N20/MAH/JLS - Reminder Recall CLEAN UP ;APR 08, 2016
- ;;5.3;Scheduling;**536,642,790**;Aug 13, 1993;Build 11
- ; Option: SDRR CLEAN-UP
- EN ;Entry point
- ;Will look at the "D" in file SD(403.5 - and loop through file 2
- ;to see if appt. has been made then delete entry in file 687065
- ;SDRRDA=IEN FOR FILE SD(403.5
- ;DFN= THE PATIENTS NUMBER
- ;REDT = RECALL DATE
- ;CLINIC = CLINIC ASSIGNED FOR THAT RECALL VISIT
- ;CLIN1 = CLINIC ASSIGN FOR THE APPT - IN FILE 2
- ;CK = APPT DATE IN FILE 2
- ;CK1 = IS THE APPT DATE MINUS TIME
- ;CAP = DIFFERENCE BETWEEN RECALL DATE AND APPT DATE - LOOKS AT -30 TO +30
- DIV Q:'$D(^SD(403.53,0))
- Q ;SD*5.3*790 - Decom Menu Option
- N SDCL,SDKF,SDRRCS,SDRRCRS ;alb/sat 642
- S CRP=0 F S CRP=$O(^SD(403.53,CRP)) Q:'CRP D
- . S PDT=$P($G(^SD(403.53,CRP,0)),"^",5) Q:PDT=""
- . S (CNT,SDRRDA)=1
- . F S CNT=$O(^SD(403.5,"D",CNT)) Q:CNT<1 D
- .. F S SDRRDA=$O(^SD(403.5,"D",CNT,SDRRDA)) Q:SDRRDA<1 D
- ...S PROV=$P($G(^SD(403.5,SDRRDA,0)),"^",5) Q:PROV=""
- ...S TEAM=$P($G(^SD(403.54,PROV,0)),"^",2) Q:TEAM=""
- ...S DIV=$P($G(^SD(403.55,TEAM,0)),"^",4) Q:DIV'=CRP
- ...S DFN=$P($G(^SD(403.5,SDRRDA,0)),"^",1) I DFN="" Q
- ...S CLINIC=$P($G(^SD(403.5,SDRRDA,0)),"^",2) I CLINIC="" Q
- ...S SDRRCS=$$GET1^DIQ(44,CLINIC_",",8,"I") S:SDRRCS'="" SDRRCS=$$GET1^DIQ(40.7,SDRRCS_",",1,"E") ;alb/sat 642
- ...S SDRRCRS=$$GET1^DIQ(44,CLINIC_",",2503,"I") S:SDRRCRS'="" SDRRCRS=$$GET1^DIQ(40.7,SDRRCRS_",",1,"E") ;alb/sat 642
- ...S REDT=$P($G(^SD(403.5,SDRRDA,0)),"^",6) I REDT="" Q
- ...D DEM^VADPT
- ...I $G(VADM(6),U)'="" S DA=SDRRDA,SDRRFTR=3,DIK="^SD(403.5," D ^DIK K DA,DIK Q
- ...N SDARRAY,SDCOUNT,SDDATE,SDAPPT,STATUS,APPT,CC,EDT,SDT
- ...S X1=REDT,X2=+PDT D C^%DTC S EDT=$P(X,".",1) K X,X1,X2
- ...S X1=REDT,X2=-PDT D C^%DTC S SDT=$P(X,".",1) K X,X1,X2
- ...S SDARRAY(1)=""_SDT_";"_EDT_""
- ...S:(SDRRCS="")&(SDRRCRS="") SDARRAY(2)=CLINIC ;alb/sat 642 SDAPI does not return based on stop code of CLINIC is passed in
- ...S SDARRAY(4)=DFN
- ...S SDARRAY("FLDS")="1;2;3;13;14" ;alb/sat 642 added 13,14
- ...S SDCOUNT=$$SDAPI^SDAMA301(.SDARRAY)
- ...I SDCOUNT>0 D
- ....S SDKF=0
- ....S SDDATE=0 F S SDDATE=$O(^TMP($J,"SDAMA301",DFN,CLINIC,SDDATE)) Q:SDDATE="" D Q:+SDKF
- .....S SDAPPT=$G(^TMP($J,"SDAMA301",DFN,CLINIC,SDDATE))
- .....S SDKF=$$PROCESS(DFN,CLINIC,SDAPPT,SDDATE,REDT,PDT,SDRRCS,SDRRCRS,SDRRDA) ;alb/sat 642 moved logic to tag PROCESS
- ....I 'SDKF S SDCL=0 F S SDCL=$O(^TMP($J,"SDAMA301",DFN,SDCL)) Q:SDCL="" D Q:+SDKF ;alb/sat 642
- .....S SDDATE=0 F S SDDATE=$O(^TMP($J,"SDAMA301",DFN,SDCL,SDDATE)) Q:SDDATE="" D Q:+SDKF
- ......S SDAPPT=$G(^TMP($J,"SDAMA301",DFN,SDCL,SDDATE))
- ......S SDKF=$$PROCESS(DFN,CLINIC,SDAPPT,SDDATE,REDT,PDT,SDRRCS,SDRRCRS,SDRRDA) ;alb/sat 642 moved logic to tag PROCESS
- ...I SDCOUNT<0 K ^TMP($J,"SDAMA301")
- ..Q
- QUIT K CNT,SDRRDA,DFN,CLINIC,CLIN1,REDT,CK,CK1,X,CAP,STATUS,PDT,TEAM,DIV,PROV,CRP,DEATH,SDRRFTR,VADM,^TMP($J,"SDAMA301")
- D KVAR^VADPT
- Q
- ;
- PROCESS(DFN,CLINIC,SDAPPT,SDDATE,REDT,PDT,SDRRCS,SDRRCRS,SDRRDA) ;alb/sat 642
- N APPT,CAP,CC,CK1,CLIN1,DA,DIK,SDAPPCST,SDAPPSTP,SDCS,SDCRS,SDKF,SDRRFTR,STATUS
- S SDKF=0
- S SDAPPSTP=$P($P(SDAPPT,U,13),";",2)
- S SDAPPCST=$P($P(SDAPPT,U,14),";",2)
- S STATUS=$P($G(SDAPPT),"^",3)
- S STATUS=$P(STATUS,";",1)
- I STATUS'="R" Q SDKF
- S APPT=$P(SDAPPT,"^",1)
- S CK1=$P(APPT,".",1)
- S CC=$P(SDAPPT,"^",2)
- S CLIN1=$P(CC,";",1)
- S CAP=$$FMDIFF^XLFDT(CK1,REDT)
- S SDCS=$S((SDAPPSTP="")&(SDRRCS=""):1,SDAPPSTP=SDRRCS:1,1:0) ;clinic stop
- S SDCRS=$S((SDAPPCST="")&(SDRRCRS=""):1,SDAPPCST=SDRRCRS:1,1:0) ;credit stop
- 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
- Q SDKF
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDRRCLR 3739 printed Jan 18, 2025@04:01:47 Page 2
- SDRRCLR ;10N20/MAH/JLS - Reminder Recall CLEAN UP ;APR 08, 2016
- +1 ;;5.3;Scheduling;**536,642,790**;Aug 13, 1993;Build 11
- +2 ; Option: SDRR CLEAN-UP
- EN ;Entry point
- +1 ;Will look at the "D" in file SD(403.5 - and loop through file 2
- +2 ;to see if appt. has been made then delete entry in file 687065
- +3 ;SDRRDA=IEN FOR FILE SD(403.5
- +4 ;DFN= THE PATIENTS NUMBER
- +5 ;REDT = RECALL DATE
- +6 ;CLINIC = CLINIC ASSIGNED FOR THAT RECALL VISIT
- +7 ;CLIN1 = CLINIC ASSIGN FOR THE APPT - IN FILE 2
- +8 ;CK = APPT DATE IN FILE 2
- +9 ;CK1 = IS THE APPT DATE MINUS TIME
- +10 ;CAP = DIFFERENCE BETWEEN RECALL DATE AND APPT DATE - LOOKS AT -30 TO +30
- DIV if '$DATA(^SD(403.53,0))
- QUIT
- +1 ;SD*5.3*790 - Decom Menu Option
- QUIT
- +2 ;alb/sat 642
- NEW SDCL,SDKF,SDRRCS,SDRRCRS
- +3 SET CRP=0
- FOR
- SET CRP=$ORDER(^SD(403.53,CRP))
- if 'CRP
- QUIT
- Begin DoDot:1
- +4 SET PDT=$PIECE($GET(^SD(403.53,CRP,0)),"^",5)
- if PDT=""
- QUIT
- +5 SET (CNT,SDRRDA)=1
- +6 FOR
- SET CNT=$ORDER(^SD(403.5,"D",CNT))
- if CNT<1
- QUIT
- Begin DoDot:2
- +7 FOR
- SET SDRRDA=$ORDER(^SD(403.5,"D",CNT,SDRRDA))
- if SDRRDA<1
- QUIT
- Begin DoDot:3
- +8 SET PROV=$PIECE($GET(^SD(403.5,SDRRDA,0)),"^",5)
- if PROV=""
- QUIT
- +9 SET TEAM=$PIECE($GET(^SD(403.54,PROV,0)),"^",2)
- if TEAM=""
- QUIT
- +10 SET DIV=$PIECE($GET(^SD(403.55,TEAM,0)),"^",4)
- if DIV'=CRP
- QUIT
- +11 SET DFN=$PIECE($GET(^SD(403.5,SDRRDA,0)),"^",1)
- IF DFN=""
- QUIT
- +12 SET CLINIC=$PIECE($GET(^SD(403.5,SDRRDA,0)),"^",2)
- IF CLINIC=""
- QUIT
- +13 ;alb/sat 642
- SET SDRRCS=$$GET1^DIQ(44,CLINIC_",",8,"I")
- if SDRRCS'=""
- SET SDRRCS=$$GET1^DIQ(40.7,SDRRCS_",",1,"E")
- +14 ;alb/sat 642
- SET SDRRCRS=$$GET1^DIQ(44,CLINIC_",",2503,"I")
- if SDRRCRS'=""
- SET SDRRCRS=$$GET1^DIQ(40.7,SDRRCRS_",",1,"E")
- +15 SET REDT=$PIECE($GET(^SD(403.5,SDRRDA,0)),"^",6)
- IF REDT=""
- QUIT
- +16 DO DEM^VADPT
- +17 IF $GET(VADM(6),U)'=""
- SET DA=SDRRDA
- SET SDRRFTR=3
- SET DIK="^SD(403.5,"
- DO ^DIK
- KILL DA,DIK
- QUIT
- +18 NEW SDARRAY,SDCOUNT,SDDATE,SDAPPT,STATUS,APPT,CC,EDT,SDT
- +19 SET X1=REDT
- SET X2=+PDT
- DO C^%DTC
- SET EDT=$PIECE(X,".",1)
- KILL X,X1,X2
- +20 SET X1=REDT
- SET X2=-PDT
- DO C^%DTC
- SET SDT=$PIECE(X,".",1)
- KILL X,X1,X2
- +21 SET SDARRAY(1)=""_SDT_";"_EDT_""
- +22 ;alb/sat 642 SDAPI does not return based on stop code of CLINIC is passed in
- if (SDRRCS="")&(SDRRCRS="")
- SET SDARRAY(2)=CLINIC
- +23 SET SDARRAY(4)=DFN
- +24 ;alb/sat 642 added 13,14
- SET SDARRAY("FLDS")="1;2;3;13;14"
- +25 SET SDCOUNT=$$SDAPI^SDAMA301(.SDARRAY)
- +26 IF SDCOUNT>0
- Begin DoDot:4
- +27 SET SDKF=0
- +28 SET SDDATE=0
- FOR
- SET SDDATE=$ORDER(^TMP($JOB,"SDAMA301",DFN,CLINIC,SDDATE))
- if SDDATE=""
- QUIT
- Begin DoDot:5
- +29 SET SDAPPT=$GET(^TMP($JOB,"SDAMA301",DFN,CLINIC,SDDATE))
- +30 ;alb/sat 642 moved logic to tag PROCESS
- SET SDKF=$$PROCESS(DFN,CLINIC,SDAPPT,SDDATE,REDT,PDT,SDRRCS,SDRRCRS,SDRRDA)
- End DoDot:5
- if +SDKF
- QUIT
- +31 ;alb/sat 642
- IF 'SDKF
- SET SDCL=0
- FOR
- SET SDCL=$ORDER(^TMP($JOB,"SDAMA301",DFN,SDCL))
- if SDCL=""
- QUIT
- Begin DoDot:5
- +32 SET SDDATE=0
- FOR
- SET SDDATE=$ORDER(^TMP($JOB,"SDAMA301",DFN,SDCL,SDDATE))
- if SDDATE=""
- QUIT
- Begin DoDot:6
- +33 SET SDAPPT=$GET(^TMP($JOB,"SDAMA301",DFN,SDCL,SDDATE))
- +34 ;alb/sat 642 moved logic to tag PROCESS
- SET SDKF=$$PROCESS(DFN,CLINIC,SDAPPT,SDDATE,REDT,PDT,SDRRCS,SDRRCRS,SDRRDA)
- End DoDot:6
- if +SDKF
- QUIT
- End DoDot:5
- if +SDKF
- QUIT
- End DoDot:4
- +35 IF SDCOUNT<0
- KILL ^TMP($JOB,"SDAMA301")
- End DoDot:3
- +36 QUIT
- End DoDot:2
- End DoDot:1
- QUIT KILL CNT,SDRRDA,DFN,CLINIC,CLIN1,REDT,CK,CK1,X,CAP,STATUS,PDT,TEAM,DIV,PROV,CRP,DEATH,SDRRFTR,VADM,^TMP($JOB,"SDAMA301")
- +1 DO KVAR^VADPT
- +2 QUIT
- +3 ;
- PROCESS(DFN,CLINIC,SDAPPT,SDDATE,REDT,PDT,SDRRCS,SDRRCRS,SDRRDA) ;alb/sat 642
- +1 NEW APPT,CAP,CC,CK1,CLIN1,DA,DIK,SDAPPCST,SDAPPSTP,SDCS,SDCRS,SDKF,SDRRFTR,STATUS
- +2 SET SDKF=0
- +3 SET SDAPPSTP=$PIECE($PIECE(SDAPPT,U,13),";",2)
- +4 SET SDAPPCST=$PIECE($PIECE(SDAPPT,U,14),";",2)
- +5 SET STATUS=$PIECE($GET(SDAPPT),"^",3)
- +6 SET STATUS=$PIECE(STATUS,";",1)
- +7 IF STATUS'="R"
- QUIT SDKF
- +8 SET APPT=$PIECE(SDAPPT,"^",1)
- +9 SET CK1=$PIECE(APPT,".",1)
- +10 SET CC=$PIECE(SDAPPT,"^",2)
- +11 SET CLIN1=$PIECE(CC,";",1)
- +12 SET CAP=$$FMDIFF^XLFDT(CK1,REDT)
- +13 ;clinic stop
- SET SDCS=$SELECT((SDAPPSTP="")&(SDRRCS=""):1,SDAPPSTP=SDRRCS:1,1:0)
- +14 ;credit stop
- SET SDCRS=$SELECT((SDAPPCST="")&(SDRRCRS=""):1,SDAPPCST=SDRRCRS:1,1:0)
- +15 IF CAP>-PDT
- IF CAP<PDT
- IF (CLIN1=CLINIC)!(SDCS&SDCRS)
- SET DA=SDRRDA
- SET SDRRFTR=7
- SET DIK="^SD(403.5,"
- DO ^DIK
- KILL DA,DIK
- SET SDKF=1
- +16 QUIT SDKF