SDECAR1A ;ALB/SAT,CT,RRM,LAB - VISTA SCHEDULING RPCS ;OCT 09,2023@08:59
;;5.3;Scheduling;**658,745,756,781,813,827,864**;Aug 13, 1993;Build 15
;;Per VHA Directive 6402, this routine should not be modified
;
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,SDECEMAIL,SDECTEXT,SDESEC
S (SDECALL,SDECLET,SDECEMAIL,SDECTEXT,SDECSEC)=""
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",REQTYPE="VETERAN":"V",1:"A") ;set request type to equal what is stored in #409.86
S CLINIC=$$GET1^DIQ(409.85,ARIEN_",",8,"I")
S PID=$$GET1^DIQ(409.85,ARIEN_",",22,"I") G:$G(PID)="" CALLETX
S SERVICE=$$GET1^DIQ(409.85,ARIEN_",",8.5,"I") S:SERVICE="" SERVICE=1 ;default to 1 for service
D DOIT(ARIEN,ARIEN_";SDEC(409.85,")
CALLETX ;EXIT CALLET
Q SDECALL_U_SDECLET_U_SDECEMAIL_U_SDECTEXT_U_SDECSEC
CALLCON(DFN,SDREC) ;GET CALL AND LETER DATA FOR A CONSULT CLT - SD*5.3*745
N REQTYPE,CLINIC,PID,SDECEMAIL,SDECTEXT,SDECSEC
S (SDECALL,SDECLET,SDECEMAIL,SDECTEXT,SDECSEC)=""
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")
S PID=$$GET1^DIQ(123,SDREC_",",17,"I") G:$G(PID)="" CALLCONX
D DOIT(SDREC,SDREC_";GMR(123,")
CALLCONX ;EXIT CALLCON
Q SDECALL_U_SDECLET_U_SDECEMAIL_U_SDECTEXT_U_SDECSEC
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,WLIEN_";SDWL(409.3,")
CALLWLX ;EXIT CALLWL
Q SDECALL_U_SDECLET
RECALL(DFN,RCIEN) ;RECALL REMINDERS CALL & LETTER ;SD*5.3*745
N REQTYPE,CLINIC,PID,SDECEMAIL,SDECTEXT,SDESEC
S (SDECALL,SDECLET,SDECEMAIL,SDECTEXT,SDECSEC)=""
S 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,RCIEN_";SD(403.5,")
RECALLX ;exit recall
Q SDECALL_U_SDECLET_U_SDECEMAIL_U_SDECTEXT_U_SDECSEC
;
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,APPTREQTYPE) ;ACTUAL GET DATA SUBROUTINE
N SDECLP,SDECG,SDECMT,SDECSUB,SDECM
S (SDECM,SDECLP)=0
S (SDECALL,SDECLET,SDECEMAIL,SDECTEXT,SDECSEC)=""
S SDECM=$O(^SDEC(409.86,"REQPTR",APPTREQTYPE,"A"),-1)
I SDECM'="" D
. S SDECG=^SDEC(409.86,SDECM,0)
. 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
.. I $P($G(^SDEC(409.86,SDECM,1,SDECLP,1)),U,1)="E" S SDECEMAIL=SDECEMAIL+1 ;GET TOTAL NUMBER OF EMAIL ATTEMPTS MADE
.. I $P($G(^SDEC(409.86,SDECM,1,SDECLP,1)),U,1)="T" S SDECTEXT=SDECTEXT+1 ;GET TOTAL NUMBER OF TEXT ATTEMPTS MADE
.. I $P($G(^SDEC(409.86,SDECM,1,SDECLP,1)),U,1)="S" S SDECSEC=SDECSEC+1 ;GET TOTAL NUMBER OF SECURE MESSAGE ATTEMPTS MADE
S:SDECLET'>0 SDECLET="" S:SDECALL'>0 SDECALL=""
S:$G(SDECLET)'="" SDECLET=$$FMTONET^SDECDATE(SDECLET,"N")
Q SDECALL_U_SDECLET_U_SDECEMAIL_U_SDECTEXT_U_SDECSEC
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECAR1A 8384 printed Sep 23, 2025@20:28:10 Page 2
SDECAR1A ;ALB/SAT,CT,RRM,LAB - VISTA SCHEDULING RPCS ;OCT 09,2023@08:59
+1 ;;5.3;Scheduling;**658,745,756,781,813,827,864**;Aug 13, 1993;Build 15
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 QUIT
+5 ;
WLPC(ARDATA,ASDIEN) ;
+1 NEW PC,PC1,PCIEN
+2 SET PC=""
+3 SET PCIEN=""
FOR
SET PCIEN=$ORDER(ARDATA(409.8544,PCIEN))
if PCIEN=""
QUIT
Begin DoDot:1
+4 if $PIECE(PCIEN,",",2)'=ASDIEN
QUIT
+5 SET PC1=""
+6 ;DATE ENTERED
SET $PIECE(PC1,"~~",1)=ARDATA(409.8544,PCIEN,.01,"E")
+7 ;PC ENTERED BY USER IEN
SET $PIECE(PC1,"~~",2)=ARDATA(409.8544,PCIEN,2,"I")
+8 ;PC ENTERED BY USER NAME
SET $PIECE(PC1,"~~",3)=ARDATA(409.8544,PCIEN,2,"E")
+9 ;ACTION
SET $PIECE(PC1,"~~",4)=ARDATA(409.8544,PCIEN,3,"E")
+10 ;PATIENT PHONE
SET $PIECE(PC1,"~~",5)=ARDATA(409.8544,PCIEN,4,"E")
+11 SET PC=$SELECT(PC'="":PC_"::",1:"")_PC1
End DoDot:1
+12 QUIT PC
+13 ;Returns multiple ptrs to SDEC APPOINTMENT (#409.84) by '|'
GETAPPTS(ARIEN) ;Get Multiple Appts Made field from SDEC APPT REQUEST file entry ARIEN
+1 NEW I,APPTS
+2 SET I=0
SET APPTS=""
+3 if '$DATA(^SDEC(409.85,ARIEN,0))
QUIT ""
+4 IF $DATA(^SDEC(409.85,ARIEN,2,0))
Begin DoDot:1
+5 SET I=0
FOR
SET I=$ORDER(^SDEC(409.85,ARIEN,2,I))
if 'I
QUIT
Begin DoDot:2
+6 ;this is correct
SET APPTS=APPTS_$SELECT(APPTS]"":"|",1:"")_$PIECE($GET(^SDEC(409.85,ARIEN,2,I,0)),U,2)
+7 ;S APPTS=APPTS_$S(APPTS]"":"|",1:"")_$P($G(^SDEC(409.85,ARIEN,2,I,0)),U,1) ;this is wrong
End DoDot:2
End DoDot:1
+8 QUIT APPTS
+9 ;
CHILDREN(ARIEN) ;Returns children SDEC APPT REQUEST pointers based on MULT APPTS MADE
+1 NEW CHILDS,MULT,REQ,SDI
+2 SET CHILDS=""
+3 SET SDI=0
FOR
SET SDI=$ORDER(^SDEC(409.85,+ARIEN,2,SDI))
if SDI'>0
QUIT
Begin DoDot:1
+4 ;this is correct
SET MULT=$PIECE($GET(^SDEC(409.85,+ARIEN,2,SDI,0)),U,1)
+5 ;S MULT=$P($G(^SDEC(409.85,+ARIEN,2,SDI,0)),U,2) ;this is wrong
+6 SET CHILDS=$SELECT(CHILDS'="":CHILDS_"|",1:"")_MULT
End DoDot:1
+7 QUIT CHILDS
+8 ;
CALLET(DFN,ARIEN) ;COUNT CALLS AND LOG THE LAST LETTER FOR APPOINTMENTS ;CT - *745 5/12/20
+1 NEW REQTYPE,CLINIC,PID,SERVICE,SDECEMAIL,SDECTEXT,SDESEC
+2 SET (SDECALL,SDECLET,SDECEMAIL,SDECTEXT,SDECSEC)=""
+3 SET REQTYPE=$$GET1^DIQ(409.85,ARIEN_",",4,"I")
if $GET(REQTYPE)=""
GOTO CALLETX
+4 ;set request type to equal what is stored in #409.86
SET REQTYPE=$SELECT(REQTYPE="APPT":"A",REQTYPE="MOBILE":"M",REQTYPE="W2VA":"W",REQTYPE="RTC":"RTC",REQTYPE="VETERAN":"V",1:"A")
+5 SET CLINIC=$$GET1^DIQ(409.85,ARIEN_",",8,"I")
+6 SET PID=$$GET1^DIQ(409.85,ARIEN_",",22,"I")
if $GET(PID)=""
GOTO CALLETX
+7 ;default to 1 for service
SET SERVICE=$$GET1^DIQ(409.85,ARIEN_",",8.5,"I")
if SERVICE=""
SET SERVICE=1
+8 DO DOIT(ARIEN,ARIEN_";SDEC(409.85,")
CALLETX ;EXIT CALLET
+1 QUIT SDECALL_U_SDECLET_U_SDECEMAIL_U_SDECTEXT_U_SDECSEC
CALLCON(DFN,SDREC) ;GET CALL AND LETER DATA FOR A CONSULT CLT - SD*5.3*745
+1 NEW REQTYPE,CLINIC,PID,SDECEMAIL,SDECTEXT,SDECSEC
+2 SET (SDECALL,SDECLET,SDECEMAIL,SDECTEXT,SDECSEC)=""
+3 SET REQTYPE=$$GET1^DIQ(123,SDREC_",",13,"I")
if $GET(REQTYPE)=""
GOTO CALLCONX
+4 ; pwc added a check for field .05 for IFC consults *745 7/27/2020
+5 SET CLINIC=$$GET1^DIQ(123,SDREC_",",2,"I")
if CLINIC=""
SET CLINIC=$$GET1^DIQ(123,SDREC_",",.05,"I")
+6 SET PID=$$GET1^DIQ(123,SDREC_",",17,"I")
if $GET(PID)=""
GOTO CALLCONX
+7 DO DOIT(SDREC,SDREC_";GMR(123,")
CALLCONX ;EXIT CALLCON
+1 QUIT SDECALL_U_SDECLET_U_SDECEMAIL_U_SDECTEXT_U_SDECSEC
CALLWL(DFN,WLIEN) ;WAITING LIST CALLS AND LETTERS ;CLT - SD*5.3*745
+1 NEW REQTYPE,CLINIC,PID
+2 SET SDECALL=""
SET SDECLET=""
SET REQTYPE="E"
+3 SET WCLN=$$GET1^DIQ(409.3,WLIEN_",",8,"I")
SET CLINIC=$$GET1^DIQ(409.32,WCLN_",",.01,"I")
if $GET(CLINIC)=""
GOTO CALLWLX
+4 SET PID=$$GET1^DIQ(409.3,WLIEN_",",22,"I")
if $GET(PID)=""
GOTO CALLWLX
+5 ;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
+6 DO DOIT(WLIEN,WLIEN_";SDWL(409.3,")
CALLWLX ;EXIT CALLWL
+1 QUIT SDECALL_U_SDECLET
RECALL(DFN,RCIEN) ;RECALL REMINDERS CALL & LETTER ;SD*5.3*745
+1 NEW REQTYPE,CLINIC,PID,SDECEMAIL,SDECTEXT,SDESEC
+2 SET (SDECALL,SDECLET,SDECEMAIL,SDECTEXT,SDECSEC)=""
+3 SET REQTYPE="R"
+4 SET CLINIC=$$GET1^DIQ(403.5,RCIEN_",",4.5,"I")
if $GET(CLINIC)=""
GOTO RECALLX
+5 ;RECALL DATE
SET PID=$$GET1^DIQ(403.5,RCIEN_",",5,"I")
if $GET(PID)=""
GOTO RECALLX
+6 ;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
+7 DO DOIT(RCIEN,RCIEN_";SD(403.5,")
RECALLX ;exit recall
+1 QUIT SDECALL_U_SDECLET_U_SDECEMAIL_U_SDECTEXT_U_SDECSEC
+2 ;
PIDDT(IN) ;SUBTRACT ONE DAY FROM PID DATE and ADD .24 FOR TIME ; PWC - SD *5.3*745
+1 NEW X,Y,X1,OUT
+2 ;
SET X=$PIECE(IN,"@",1)
SET %DT=""
DO ^%DT
SET X=$$FMADD^DILIBF(Y,-1,0,0,1)
SET X1=$PIECE(X,".",1)
+3 ;
SET OUT=X1_".24"
+4 QUIT OUT
+5 ;
DOIT(SDIEN,APPTREQTYPE) ;ACTUAL GET DATA SUBROUTINE
+1 NEW SDECLP,SDECG,SDECMT,SDECSUB,SDECM
+2 SET (SDECM,SDECLP)=0
+3 SET (SDECALL,SDECLET,SDECEMAIL,SDECTEXT,SDECSEC)=""
+4 SET SDECM=$ORDER(^SDEC(409.86,"REQPTR",APPTREQTYPE,"A"),-1)
+5 IF SDECM'=""
Begin DoDot:1
+6 SET SDECG=^SDEC(409.86,SDECM,0)
+7 IF $DATA(^SDEC(409.86,SDECM,1,0))
SET SDECSUB=$PIECE(^SDEC(409.86,SDECM,1,0),U,3)
+8 ; reset SDECLP varible each time you have a new SDECM variable
if $GET(SDECSUB)=""
QUIT
SET SDECLP=$PIECE(SDECG,U,5)-1
+9 FOR
SET SDECLP=$ORDER(^SDEC(409.86,SDECM,1,SDECLP))
if (SDECLP)'?.N
QUIT
Begin DoDot:2
+10 ;GET TOTAL NUMBER OF CALLS ATTEMPTS MADE
IF $PIECE($GET(^SDEC(409.86,SDECM,1,SDECLP,1)),U,1)="C"
SET SDECALL=SDECALL+1
+11 ;DATE OF CONTACT only keep the last date
IF $PIECE($GET(^SDEC(409.86,SDECM,1,SDECLP,1)),U,1)="L"
if $PIECE(^SDEC(409.86,SDECM,1,SDECLP,0),U,1)>SDECLET
SET SDECLET=$PIECE($PIECE(^(0),U,1),".",1)
+12 ;GET TOTAL NUMBER OF EMAIL ATTEMPTS MADE
IF $PIECE($GET(^SDEC(409.86,SDECM,1,SDECLP,1)),U,1)="E"
SET SDECEMAIL=SDECEMAIL+1
+13 ;GET TOTAL NUMBER OF TEXT ATTEMPTS MADE
IF $PIECE($GET(^SDEC(409.86,SDECM,1,SDECLP,1)),U,1)="T"
SET SDECTEXT=SDECTEXT+1
+14 ;GET TOTAL NUMBER OF SECURE MESSAGE ATTEMPTS MADE
IF $PIECE($GET(^SDEC(409.86,SDECM,1,SDECLP,1)),U,1)="S"
SET SDECSEC=SDECSEC+1
End DoDot:2
End DoDot:1
+15 if SDECLET'>0
SET SDECLET=""
if SDECALL'>0
SET SDECALL=""
+16 if $GET(SDECLET)'=""
SET SDECLET=$$FMTONET^SDECDATE(SDECLET,"N")
+17 QUIT SDECALL_U_SDECLET_U_SDECEMAIL_U_SDECTEXT_U_SDECSEC
+18 ;
ARDEMO(STR,DFN) ;collect patient demographics and return in STR ;alb/sat 658
+1 NEW PRIGRP,SDDEMO
+2 ;alb/sat 658 PDEMO moved to SDECU3
DO PDEMO^SDECU3(.SDDEMO,DFN)
+3 SET $PIECE(STR,U,2)=SDDEMO("NAME")
+4 SET $PIECE(STR,U,4)=SDDEMO("DOB")
+5 SET $PIECE(STR,U,5)=SDDEMO("SSN")
+6 SET $PIECE(STR,U,6)=SDDEMO("GENDER")
+7 SET (PRIGRP,$PIECE(STR,U,26))=SDDEMO("PRIGRP")
+8 SET $PIECE(STR,U,27)=SDDEMO("ELIGIEN")
+9 SET $PIECE(STR,U,28)=SDDEMO("ELIGNAME")
+10 SET $PIECE(STR,U,29)=SDDEMO("SVCCONN")
+11 SET $PIECE(STR,U,30)=SDDEMO("SVCCONNP")
+12 SET $PIECE(STR,U,31)=SDDEMO("TYPEIEN")
+13 SET $PIECE(STR,U,32)=SDDEMO("TYPENAME")
+14 SET $PIECE(STR,U,38)=SDDEMO("PADDRES1")
+15 SET $PIECE(STR,U,39)=SDDEMO("PADDRES2")
+16 SET $PIECE(STR,U,40)=SDDEMO("PADDRES3")
+17 SET $PIECE(STR,U,41)=SDDEMO("PCITY")
+18 SET $PIECE(STR,U,42)=SDDEMO("PSTATE")
+19 SET $PIECE(STR,U,43)=SDDEMO("PCOUNTRY")
+20 SET $PIECE(STR,U,44)=SDDEMO("PZIP+4")
+21 ;alb/sat 658 change to HPHONE
SET $PIECE(STR,U,61)=SDDEMO("HPHONE")
+22 ;
+23 SET $PIECE(STR,U,68)=SDDEMO("HRN")
+24 SET $PIECE(STR,U,69)=SDDEMO("BADADD")
+25 SET $PIECE(STR,U,70)=SDDEMO("OPHONE")
+26 SET $PIECE(STR,U,71)=SDDEMO("NOK")
+27 SET $PIECE(STR,U,72)=SDDEMO("KNAME")
+28 SET $PIECE(STR,U,73)=SDDEMO("KREL")
+29 SET $PIECE(STR,U,74)=SDDEMO("KPHONE")
+30 SET $PIECE(STR,U,75)=SDDEMO("KSTREET")
+31 SET $PIECE(STR,U,76)=SDDEMO("KSTREET2")
+32 SET $PIECE(STR,U,77)=SDDEMO("KSTREET3")
+33 SET $PIECE(STR,U,78)=SDDEMO("KCITY")
+34 SET $PIECE(STR,U,79)=SDDEMO("KSTATE")
+35 SET $PIECE(STR,U,80)=SDDEMO("KZIP")
+36 SET $PIECE(STR,U,81)=SDDEMO("NOK2")
+37 SET $PIECE(STR,U,82)=SDDEMO("K2NAME")
+38 SET $PIECE(STR,U,83)=SDDEMO("K2REL")
+39 SET $PIECE(STR,U,84)=SDDEMO("K2PHONE")
+40 SET $PIECE(STR,U,85)=SDDEMO("K2STREET")
+41 SET $PIECE(STR,U,86)=SDDEMO("K2STREET2")
+42 SET $PIECE(STR,U,87)=SDDEMO("K2STREET3")
+43 SET $PIECE(STR,U,88)=SDDEMO("K2CITY")
+44 SET $PIECE(STR,U,89)=SDDEMO("K2STATE")
+45 SET $PIECE(STR,U,90)=SDDEMO("K2ZIP")
+46 SET $PIECE(STR,U,91)=SDDEMO("PCOUNTY")
+47 SET $PIECE(STR,U,92)=SDDEMO("PETH")
+48 SET $PIECE(STR,U,93)=SDDEMO("PRACE")
+49 SET $PIECE(STR,U,94)=SDDEMO("PMARITAL")
+50 SET $PIECE(STR,U,95)=SDDEMO("PRELIGION")
+51 SET $PIECE(STR,U,96)=SDDEMO("PTACTIVE")
+52 SET $PIECE(STR,U,97)=SDDEMO("PTADDRESS1")
+53 SET $PIECE(STR,U,98)=SDDEMO("PTADDRESS2")
+54 SET $PIECE(STR,U,99)=SDDEMO("PTADDRESS3")
+55 SET $PIECE(STR,U,100)=SDDEMO("PTCITY")
+56 SET $PIECE(STR,U,101)=SDDEMO("PTSTATE")
+57 SET $PIECE(STR,U,102)=SDDEMO("PTZIP")
+58 SET $PIECE(STR,U,103)=SDDEMO("PTZIP+4")
+59 SET $PIECE(STR,U,104)=SDDEMO("PTCOUNTRY")
+60 SET $PIECE(STR,U,105)=SDDEMO("PTCOUNTY")
+61 SET $PIECE(STR,U,106)=SDDEMO("PTPHONE")
+62 SET $PIECE(STR,U,107)=SDDEMO("PTSTART")
+63 SET $PIECE(STR,U,108)=SDDEMO("PTEND")
+64 SET $PIECE(STR,U,109)=SDDEMO("PCELL")
+65 SET $PIECE(STR,U,110)=SDDEMO("PPAGER")
+66 SET $PIECE(STR,U,111)=SDDEMO("PEMAIL")
+67 SET $PIECE(STR,U,112)=SDDEMO("PF_FFF")
+68 SET $PIECE(STR,U,113)=SDDEMO("PF_VCD")
+69 SET $PIECE(STR,U,114)=SDDEMO("PFNATIONAL")
+70 SET $PIECE(STR,U,115)=SDDEMO("PFLOCAL")
+71 SET $PIECE(STR,U,116)=SDDEMO("SUBGRP")
+72 SET $PIECE(STR,U,117)=(PRIGRP="GROUP 8")&(SDDEMO("SUBGRP")="g")
+73 SET $PIECE(STR,U,118)=SDDEMO("SIMILAR")
+74 QUIT
