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

SDECAR1A.m

Go to the documentation of this file.
SDECAR1A ;ALB/SAT,CT - VISTA SCHEDULING RPCS ;Apr 02, 2021@12:06:05
 ;;5.3;Scheduling;**658,745,756,781**;Aug 13, 1993;Build 11
 ;
 Q
 ;
WLPC(ARDATA,ASDIEN) ;
 N PC,PC1,PCIEN
 S PC=""
 S PCIEN="" F  S PCIEN=$O(ARDATA(409.8544,PCIEN)) Q:PCIEN=""  D
 .Q:$P(PCIEN,",",2)'=ASDIEN
 .S PC1=""
 .S $P(PC1,"~~",1)=ARDATA(409.8544,PCIEN,.01,"E")    ;DATE ENTERED
 .S $P(PC1,"~~",2)=ARDATA(409.8544,PCIEN,2,"I")      ;PC ENTERED BY USER IEN
 .S $P(PC1,"~~",3)=ARDATA(409.8544,PCIEN,2,"E")      ;PC ENTERED BY USER NAME
 .S $P(PC1,"~~",4)=ARDATA(409.8544,PCIEN,3,"E")      ;ACTION
 .S $P(PC1,"~~",5)=ARDATA(409.8544,PCIEN,4,"E")      ;PATIENT PHONE
 .S PC=$S(PC'="":PC_"::",1:"")_PC1
 Q PC
 ;Returns multiple ptrs to SDEC APPOINTMENT (#409.84) by '|'
GETAPPTS(ARIEN) ;Get Multiple Appts Made field from SDEC APPT REQUEST file entry ARIEN
 N I,APPTS
 S I=0,APPTS=""
 Q:'$D(^SDEC(409.85,ARIEN,0)) ""
 I $D(^SDEC(409.85,ARIEN,2,0)) D
 .S I=0 F  S I=$O(^SDEC(409.85,ARIEN,2,I)) Q:'I  D
 ..S APPTS=APPTS_$S(APPTS]"":"|",1:"")_$P($G(^SDEC(409.85,ARIEN,2,I,0)),U,2)  ;this is correct
 ..;S APPTS=APPTS_$S(APPTS]"":"|",1:"")_$P($G(^SDEC(409.85,ARIEN,2,I,0)),U,1)   ;this is wrong
 Q APPTS
 ;
CHILDREN(ARIEN) ;Returns children SDEC APPT REQUEST pointers based on MULT APPTS MADE
 N CHILDS,MULT,REQ,SDI
 S CHILDS=""
 S SDI=0 F  S SDI=$O(^SDEC(409.85,+ARIEN,2,SDI)) Q:SDI'>0  D
 .S MULT=$P($G(^SDEC(409.85,+ARIEN,2,SDI,0)),U,1) ;this is correct
 .;S MULT=$P($G(^SDEC(409.85,+ARIEN,2,SDI,0)),U,2)  ;this is wrong
 .S CHILDS=$S(CHILDS'="":CHILDS_"|",1:"")_MULT
 Q CHILDS
 ;
CALLET(DFN,ARIEN)  ;COUNT CALLS AND LOG THE LAST LETTER FOR APPOINTMENTS  ;CT - *745 5/12/20
 N REQTYPE,CLINIC,PID,SERVICE
 S SDECALL="",SDECLET=""
 S REQTYPE=$$GET1^DIQ(409.85,ARIEN_",",4,"I") G:$G(REQTYPE)="" CALLETX
 S REQTYPE=$S(REQTYPE="APPT":"A",REQTYPE="MOBILE":"M",REQTYPE="W2VA":"W",REQTYPE="RTC":"RTC",1:"A")  ;set request type to equal what is stored in #409.86
 S CLINIC=$$GET1^DIQ(409.85,ARIEN_",",8,"I") G:$G(CLINIC)="" CALLETX
 S PID=$$GET1^DIQ(409.85,ARIEN_",",22,"I") G:$G(PID)="" CALLETX
 ;S PID=$$PIDDT(PID)  ;convert PID to PID minus one day and add .24 to it to match the date in the contact file, zero node  ; pwc *756 8/31/20
 S SERVICE=$$GET1^DIQ(409.85,ARIEN_",",8.5,"I") S:SERVICE="" SERVICE=1   ;default to 1 for service
 D DOIT(ARIEN)
CALLETX ;EXIT CALLET
 Q SDECALL_U_SDECLET
CALLCON(DFN,SDREC) ;GET CALL AND LETER DATA FOR A CONSULT  CLT - SD*5.3*745
 N REQTYPE,CLINIC,PID
 S SDECALL="",SDECLET=""
 S REQTYPE=$$GET1^DIQ(123,SDREC_",",13,"I") G:$G(REQTYPE)="" CALLCONX
 ; pwc added a check for field .05 for IFC consults *745 7/27/2020
 S CLINIC=$$GET1^DIQ(123,SDREC_",",2,"I") S:CLINIC="" CLINIC=$$GET1^DIQ(123,SDREC_",",.05,"I") G:$G(CLINIC)="" CALLCONX
 S PID=$$GET1^DIQ(123,SDREC_",",17,"I") G:$G(PID)="" CALLCONX
 ;S PID=$$PIDDT(PID)  ;convert PID to PID minus one day and add .24 to it to match the date in the contact file, zero node  ; pwc *756 8/31/20
 D DOIT(SDREC)
CALLCONX ;EXIT CALLCON
 Q SDECALL_U_SDECLET
CALLWL(DFN,WLIEN) ;WAITING LIST CALLS AND LETTERS  ;CLT - SD*5.3*745
 N REQTYPE,CLINIC,PID
 S SDECALL="",SDECLET="",REQTYPE="E"
 S WCLN=$$GET1^DIQ(409.3,WLIEN_",",8,"I"),CLINIC=$$GET1^DIQ(409.32,WCLN_",",.01,"I") G:$G(CLINIC)="" CALLWLX
 S PID=$$GET1^DIQ(409.3,WLIEN_",",22,"I") G:$G(PID)="" CALLWLX
 ;S PID=$$PIDDT(PID)  ;convert PID to PID minus one day and add .24 to it to match the date in the contact file, zero node  ; pwc *756 8/31/20
 D DOIT(WLIEN)
CALLWLX ;EXIT CALLWL
 Q SDECALL_U_SDECLET
RECALL(DFN,RCIEN) ;RECALL REMINDERS CALL & LETTER  ;SD*5.3*745
 N REQTYPE,CLINIC,PID
 S SDECALL="",SDECLET="",REQTYPE="R"
 S CLINIC=$$GET1^DIQ(403.5,RCIEN_",",4.5,"I") G:$G(CLINIC)="" RECALLX
 S PID=$$GET1^DIQ(403.5,RCIEN_",",5,"I") G:$G(PID)="" RECALLX   ;RECALL DATE
 ;S PID=$$PIDDT(PID)  ;convert PID to PID minus one day and add .24 to it to match the date in the contact file, zero node  ; pwc *756 8/31/20
 D DOIT(RCIEN)
RECALLX ;exit recall
 Q SDECALL_U_SDECLET
 ;
PIDDT(IN) ;SUBTRACT ONE DAY FROM PID DATE and ADD .24 FOR TIME  ; PWC - SD *5.3*745
 N X,Y,X1,OUT
 S X=$P(IN,"@",1),%DT="" D ^%DT S X=$$FMADD^DILIBF(Y,-1,0,0,1),X1=$P(X,".",1) ;
 S OUT=X1_".24" ;
 Q OUT
 ;
DOIT(SDIEN) ;ACTUAL GET DATA SUBROUTINE  ;CLT - SD*5.3*745; MGD - *781 Added parameter to fix erroneous call count issue
 ; changed DFN to SDECM to match how file is created
 N SDECM,SDECLP,SDECG,SDECMT,SDECMTCH,SDECSUB
 S (SDECM,SDECLP)=0,(SDECALL,SDECLET)=""
 S SDECMTCH=DFN_U_REQTYPE_U_CLINIC_U_PID   ;MATCH THIS ARRAY FOR PROPER ENTRY IN FILE 409.86
 ;LOOP THROUGH "B" X-REF TO FIND ENTRIES TO MATCH
 F  S SDECM=$O(^SDEC(409.86,"B",DFN,SDECM)) Q:SDECM=""  D
 . S SDECG=^SDEC(409.86,SDECM,0)
 . Q:SDIEN=""  Q:+$P(SDECG,U,7)'=SDIEN  ; Only include records for unique record identified by RCIEN MGD:781
 . S SDECMT=DFN_U_$P(SDECG,U,4)_U_$P(SDECG,U,2)_U_$P(SDECG,U,3)   ;BUILD ARRAY FOR MATCH
 . I SDECMTCH=SDECMT D
 .. I $D(^SDEC(409.86,SDECM,1,0)) S SDECSUB=$P(^SDEC(409.86,SDECM,1,0),U,3)
 .. Q:$G(SDECSUB)=""  S SDECLP=$P(SDECG,U,5)-1    ; reset SDECLP varible each time you have a new SDECM variable
 .. F  S SDECLP=$O(^SDEC(409.86,SDECM,1,SDECLP)) Q:(SDECLP)'?.N  D
 ... I $P($G(^SDEC(409.86,SDECM,1,SDECLP,1)),U,1)="C" S SDECALL=SDECALL+1   ;GET TOTAL NUMBER OF CALLS ATTEMPTS MADE
 ... I $P($G(^SDEC(409.86,SDECM,1,SDECLP,1)),U,1)="L" S:$P(^SDEC(409.86,SDECM,1,SDECLP,0),U,1)>SDECLET SDECLET=$P($P(^(0),U,1),".",1)  ;DATE OF CONTACT only keep the last date
 S:SDECLET'>0 SDECLET="" S:SDECALL'>0 SDECALL=""
 S:$G(SDECLET)'="" SDECLET=$$FMTONET^SDECDATE(SDECLET,"N")
 Q SDECALL_U_SDECLET
 ;
ARDEMO(STR,DFN)  ;collect patient demographics and return in STR   ;alb/sat 658
 N PRIGRP,SDDEMO
 D PDEMO^SDECU3(.SDDEMO,DFN)  ;alb/sat 658 PDEMO moved to SDECU3
 S $P(STR,U,2)=SDDEMO("NAME")
 S $P(STR,U,4)=SDDEMO("DOB")
 S $P(STR,U,5)=SDDEMO("SSN")
 S $P(STR,U,6)=SDDEMO("GENDER")
 S (PRIGRP,$P(STR,U,26))=SDDEMO("PRIGRP")
 S $P(STR,U,27)=SDDEMO("ELIGIEN")
 S $P(STR,U,28)=SDDEMO("ELIGNAME")
 S $P(STR,U,29)=SDDEMO("SVCCONN")
 S $P(STR,U,30)=SDDEMO("SVCCONNP")
 S $P(STR,U,31)=SDDEMO("TYPEIEN")
 S $P(STR,U,32)=SDDEMO("TYPENAME")
 S $P(STR,U,38)=SDDEMO("PADDRES1")
 S $P(STR,U,39)=SDDEMO("PADDRES2")
 S $P(STR,U,40)=SDDEMO("PADDRES3")
 S $P(STR,U,41)=SDDEMO("PCITY")
 S $P(STR,U,42)=SDDEMO("PSTATE")
 S $P(STR,U,43)=SDDEMO("PCOUNTRY")
 S $P(STR,U,44)=SDDEMO("PZIP+4")
 S $P(STR,U,61)=SDDEMO("HPHONE")  ;alb/sat 658 change to HPHONE
 ;
 S $P(STR,U,68)=SDDEMO("HRN")
 S $P(STR,U,69)=SDDEMO("BADADD")
 S $P(STR,U,70)=SDDEMO("OPHONE")
 S $P(STR,U,71)=SDDEMO("NOK")
 S $P(STR,U,72)=SDDEMO("KNAME")
 S $P(STR,U,73)=SDDEMO("KREL")
 S $P(STR,U,74)=SDDEMO("KPHONE")
 S $P(STR,U,75)=SDDEMO("KSTREET")
 S $P(STR,U,76)=SDDEMO("KSTREET2")
 S $P(STR,U,77)=SDDEMO("KSTREET3")
 S $P(STR,U,78)=SDDEMO("KCITY")
 S $P(STR,U,79)=SDDEMO("KSTATE")
 S $P(STR,U,80)=SDDEMO("KZIP")
 S $P(STR,U,81)=SDDEMO("NOK2")
 S $P(STR,U,82)=SDDEMO("K2NAME")
 S $P(STR,U,83)=SDDEMO("K2REL")
 S $P(STR,U,84)=SDDEMO("K2PHONE")
 S $P(STR,U,85)=SDDEMO("K2STREET")
 S $P(STR,U,86)=SDDEMO("K2STREET2")
 S $P(STR,U,87)=SDDEMO("K2STREET3")
 S $P(STR,U,88)=SDDEMO("K2CITY")
 S $P(STR,U,89)=SDDEMO("K2STATE")
 S $P(STR,U,90)=SDDEMO("K2ZIP")
 S $P(STR,U,91)=SDDEMO("PCOUNTY")
 S $P(STR,U,92)=SDDEMO("PETH")
 S $P(STR,U,93)=SDDEMO("PRACE")
 S $P(STR,U,94)=SDDEMO("PMARITAL")
 S $P(STR,U,95)=SDDEMO("PRELIGION")
 S $P(STR,U,96)=SDDEMO("PTACTIVE")
 S $P(STR,U,97)=SDDEMO("PTADDRESS1")
 S $P(STR,U,98)=SDDEMO("PTADDRESS2")
 S $P(STR,U,99)=SDDEMO("PTADDRESS3")
 S $P(STR,U,100)=SDDEMO("PTCITY")
 S $P(STR,U,101)=SDDEMO("PTSTATE")
 S $P(STR,U,102)=SDDEMO("PTZIP")
 S $P(STR,U,103)=SDDEMO("PTZIP+4")
 S $P(STR,U,104)=SDDEMO("PTCOUNTRY")
 S $P(STR,U,105)=SDDEMO("PTCOUNTY")
 S $P(STR,U,106)=SDDEMO("PTPHONE")
 S $P(STR,U,107)=SDDEMO("PTSTART")
 S $P(STR,U,108)=SDDEMO("PTEND")
 S $P(STR,U,109)=SDDEMO("PCELL")
 S $P(STR,U,110)=SDDEMO("PPAGER")
 S $P(STR,U,111)=SDDEMO("PEMAIL")
 S $P(STR,U,112)=SDDEMO("PF_FFF")
 S $P(STR,U,113)=SDDEMO("PF_VCD")
 S $P(STR,U,114)=SDDEMO("PFNATIONAL")
 S $P(STR,U,115)=SDDEMO("PFLOCAL")
 S $P(STR,U,116)=SDDEMO("SUBGRP")
 S $P(STR,U,117)=(PRIGRP="GROUP 8")&(SDDEMO("SUBGRP")="g")
 S $P(STR,U,118)=SDDEMO("SIMILAR")
 Q