- SDRRCLR ;10N20/MAH;-Reminder Recall CLEAN UP ;01/18/2008 11:32
- ;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20
- ; 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))
- 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 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 SDARRAY(2)=CLINIC
- ... S SDARRAY(4)=DFN
- ... S SDARRAY("FLDS")="1;2;3"
- ... S SDCOUNT=$$SDAPI^SDAMA301(.SDARRAY)
- ... I SDCOUNT>0 D
- .... S SDDATE=0 F S SDDATE=$O(^TMP($J,"SDAMA301",DFN,CLINIC,SDDATE)) Q:SDDATE="" D
- ..... S SDAPPT=$G(^TMP($J,"SDAMA301",DFN,CLINIC,SDDATE))
- ..... S STATUS=$P($G(SDAPPT),"^",3)
- ..... S STATUS=$P(STATUS,";",1)
- ..... I STATUS'="R" Q
- ..... 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)
- ..... I CAP>-PDT,CAP<PDT I CLIN1=CLINIC S DA=SDRRDA,SDRRFTR=7,DIK="^SD(403.5," D ^DIK K DA,DIK
- ..... Q
- ... 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
- SDRRCLR ;10N20/MAH;-Reminder Recall CLEAN UP ;01/18/2008 11:32
- +1 ;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20
- +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 SET CRP=0
- FOR
- SET CRP=$ORDER(^SD(403.53,CRP))
- IF 'CRP
- QUIT
- Begin DoDot:1
- +2 SET PDT=$PIECE($GET(^SD(403.53,CRP,0)),"^",5)
- IF PDT=""
- QUIT
- +3 SET (CNT,SDRRDA)=1
- +4 FOR
- SET CNT=$ORDER(^SD(403.5,"D",CNT))
- IF CNT<1
- QUIT
- Begin DoDot:2
- +5 FOR
- SET SDRRDA=$ORDER(^SD(403.5,"D",CNT,SDRRDA))
- IF SDRRDA<1
- QUIT
- Begin DoDot:3
- +6 SET PROV=$PIECE($GET(^SD(403.5,SDRRDA,0)),"^",5)
- IF PROV=""
- QUIT
- +7 SET TEAM=$PIECE($GET(^SD(403.54,PROV,0)),"^",2)
- IF TEAM=""
- QUIT
- +8 SET DIV=$PIECE($GET(^SD(403.55,TEAM,0)),"^",4)
- IF DIV'=CRP
- QUIT
- +9 SET DFN=$PIECE($GET(^SD(403.5,SDRRDA,0)),"^",1)
- IF DFN=""
- QUIT
- +10 SET CLINIC=$PIECE($GET(^SD(403.5,SDRRDA,0)),"^",2)
- IF CLINIC=""
- QUIT
- +11 SET REDT=$PIECE($GET(^SD(403.5,SDRRDA,0)),"^",6)
- IF REDT=""
- QUIT
- +12 DO DEM^VADPT
- +13 IF $GET(VADM(6),U)'=""
- SET DA=SDRRDA
- SET SDRRFTR=3
- SET DIK="^SD(403.5,"
- DO ^DIK
- KILL DA,DIK
- QUIT
- +14 NEW SDARRAY,SDCOUNT,SDDATE,SDAPPT,STATUS,APPT,CC,EDT,SDT
- +15 SET X1=REDT
- SET X2=+PDT
- DO C^%DTC
- SET EDT=$PIECE(X,".",1)
- KILL X,X1,X2
- +16 SET X1=REDT
- SET X2=-PDT
- DO C^%DTC
- SET SDT=$PIECE(X,".",1)
- KILL X,X1,X2
- +17 SET SDARRAY(1)=""_SDT_";"_EDT_""
- +18 SET SDARRAY(2)=CLINIC
- +19 SET SDARRAY(4)=DFN
- +20 SET SDARRAY("FLDS")="1;2;3"
- +21 SET SDCOUNT=$$SDAPI^SDAMA301(.SDARRAY)
- +22 IF SDCOUNT>0
- Begin DoDot:4
- +23 SET SDDATE=0
- FOR
- SET SDDATE=$ORDER(^TMP($JOB,"SDAMA301",DFN,CLINIC,SDDATE))
- IF SDDATE=""
- QUIT
- Begin DoDot:5
- +24 SET SDAPPT=$GET(^TMP($JOB,"SDAMA301",DFN,CLINIC,SDDATE))
- +25 SET STATUS=$PIECE($GET(SDAPPT),"^",3)
- +26 SET STATUS=$PIECE(STATUS,";",1)
- +27 IF STATUS'="R"
- QUIT
- +28 SET APPT=$PIECE(SDAPPT,"^",1)
- +29 SET CK1=$PIECE(APPT,".",1)
- +30 SET CC=$PIECE(SDAPPT,"^",2)
- +31 SET CLIN1=$PIECE(CC,";",1)
- +32 SET CAP=$$FMDIFF^XLFDT(CK1,REDT)
- +33 IF CAP>-PDT
- IF CAP<PDT
- IF CLIN1=CLINIC
- SET DA=SDRRDA
- SET SDRRFTR=7
- SET DIK="^SD(403.5,"
- DO ^DIK
- KILL DA,DIK
- +34 QUIT
- End DoDot:5
- 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
