SDEC09 ;ALB/SAT/LAB - VISTA SCHEDULING RPCS ;JUL 26,2022
;;5.3;Scheduling;**627,642,658,679,801,809,823**;Aug 13, 1993;Build 9
;;Per VHA Directive 6402, this routine should not be modified
;
; Reference to ^DPT in ICR #10035
; Reference to ^DGS(41.41 in ICR #4425
;
Q
;
;
GETREGA(SDECRET,DFN) ;return basic reg info/demographics for given patient
;GETREGA(SDECRET,DFN) external parameter tag is in SDEC
;DFN - Patient ID - Pointer to PATIENT file
;Returns IEN^STREET^CITY^STATE^ZIP^NAME^DOB^SSN^HRN
; 10 HOMEPHONE - Residence or Phone #1
; 11 OFCPHONE - Office/Work Phone
; 12 MSGPHONE - Also referred to as Phone #2 and Temporary Phone number
; 13 NOK NAME^RELATIONSHIP^PHONE^STREET^CITY^STATE^NOK_ZIP
; 20 DATAREVIEWED^
; 21 Medicare#^Suffix
; 23 RegistrationComments
; 24 GAF - <text> | <GAF score> | <GAF date> | <diagnosis by IEN> | <diagnosis by name>
; 25 PRACE - Patient Race pointer to RACE file 10 | separates entries
; 26 PRACEN - Patient Race name from RACE file | separates entries
; 27 PETH - Patient Ethnicity list separated by pipe |
; Pointer to ETHNICITY file 10.2
; 28 PETHN - Patient Ethnicity names separated by pipe |
; 29 PCOUNTRY - Country pointer to COUNTRY CODE file
; 30 GENDER - Patient Gender - valid values are MALE FEMALE
; 31 SENSITIVE - Sensitive Record Access data separated by pipe |:
; 1. return code:
; -1-RPC/API failed
; Required variable not defined
; 0-No display/action required
; Not accessing own, employee, or sensitive record
; 1-Display warning message
; Sensitive and DG SENSITIVITY key holder
; or Employee and DG SECURITY OFFICER key holder
; 2-Display warning message/require OK to continue
; Sensitive and not a DG SENSITIVITY key holder
; Employee and not a DG SECURITY OFFICER key holder
; 3-Access to record denied
; Accessing own record
; 4-Access to Patient (#2) file records denied
; SSN not defined
; 2. display text/message
; 3. display text/message
; 4. display text/message
; 32 SVCCONN - Patient's Service Connected status
; YES NO
; 33 SVCCONNP - Patient's Service Connected Percentage
; Numeric 0-100
; 34 BADADD - BAD ADDRESS INDICATOR
; 1=UNDELIVERABLE
; 2=HOMELESS
; 3=OTHER
; 4=ADDRESS NOT FOUND
; 35. PADDRES2 - Patient Street Address line 2
; 36. PADDRES3 - Patient Street Address line 3
; 37. PCOUNTY - Patient's County
; 38. PCELL - Patient's Cell Phone
; 39. PEMAIL - Patient's Email address
; 40. PMARITAL - Patient Marital Status
; 41. PRELIGION - Patient Religious Preference
; 42. PTADDRESS1 - Patient Temporary Address Line 1 (.1211)
; 43. PTADDRESS2 - Patient Temporary Address Line 2 (.1212)
; 44. PTADDRESS3 - Patient Temporary Address Line 3 (.1213)
; 45. PTCITY - Patient Temporary City (.1214)
; 46. PTSTATE - Patient Temporary State (.1215)
; 47. PTZIP - Patient Temporary Zip (.1216)
; 48. PTZIP+4 - Patient Temporary Zip+4 (.12112)
; 49. PTCOUNTRY - Patient Temporary Country (.1223)
; 50. PTCOUNTY - Patient Temporary County (.12111)
; 51. PTSTART - Patient Temporary Address Start Date (.1217)
; 52. PTEND - Patient Temporary Address End Date (.1218)
; 53. KSTREET2 - Primary Next of Kin Street Address [Line 2] (.214)
; 54. KSTREET3 - Primary Next of Kin Street Address [Line 3] (.215)
; 55. NOK2 - Secondary Next of Kin (.2191)
; 56. K2NAME - Secondary Next of Kin name (.2191)
; 57. K2REL - Secondary Next of Kin Relationship to Patient (.2192)
; 58. K2PHONE - Secondary Next of Kin Phone (.2199)
; 59. K2STREET - Secondary Next of Kin Street Address [Line 1] (.2193)
; 60. K2STREET2 - Secondary Next of Kin Street Address [Line 2] (.2194)
; 61. K2STREET3 - Secondary Next of Kin Street Address [Line 3] (.2195)
; 62. K2CITY - Secondary Next of Kin City (.2196)
; 63. K2STATE - Secondary Next of Kin State (.2197)
; 64. K2ZIP - Secondary Next of Kin Zip (.2198)
; 65. PF_FFF - Patient FUGITIVE FELON FLAG 1=YES
; 66. PF_VCD - Patient VETERAN CATASTROPHICALLY DISABLED? Y=YES N=NO
; 67. PFNATIONAL - Patient national Flags (PRF ASSIGNMENT/PRF NATIONAL FLAG) separated by ^
; Each ^ piece contains the following | pipe pieces:
; 1. PRFAID - PRF Assignment ID pointer to PRF ASSIGNMENT file (#26.13)
; 2. PRFSTAT - PRF Assignment Status 0=INACTIVE 1=ACTIVE
; 3. PRFNID - PRF National Flag ID pointer to PRF NATIONAL FLAG file (#26.15)
; 4. PRFNNAME - PRF National Flag name
; 5. PRFNSTAT - PRF National Flag status 0=INACTIVE 1=ACTIVE
; 68. PFLOCAL - Patient Local Flags (PRF ASSIGNMENT/PRF Local FLAG) separated by ^
; Each ^ piece contains the following | pipe pieces:
; 1. PRFAID - PRF Assignment ID pointer to PRF ASSIGNMENT file (#26.13)
; 2. PRFSTAT - PRF Assignment Status 0=INACTIVE 1=ACTIVE
; 3. PRFLID - PRF Local Flag ID pointer to PRF LOCAL FLAG file (#26.11)
; 4. PRFLNAME - PRF Local Flag name
; 5. PRFLSTAT - PRF Local Flag status 0=INACTIVE 1=ACTIVE
; 72. PRIGRP - Patient Enrollment Priority Group
; 73. PCP
; 74. MHP
; 75. PREFGEN - Patient Self Identified Gender
; 76. PREREGTIM- Preregistration time stamp
; 77. PREFNAME - Preferred Name
;For patient with ien DFN
;K ^TMP("SDEC",$J)
N SDDEMO,SDECI,SDECNOD,SDECNAM,SDECTMP,SDSENS,Y,PREFGEN
N PRACE,PRACEN,PETH,PETHN,PCOUNTRY,SVCCONN,SVCCONNP,SDPCP,SDMHP,PREREGTIMIEN,PREREGTIM,PREFNAME
S SDECRET="^TMP(""SDEC"","_$J_")"
K @SDECRET
S SDECI=0
;
S SDECTMP="T00030IEN^T00030STREET^T00030CITY/STATE^T00030WARD:^T00030ZIP^T00030NAME^D00030DOB^T00030SSN^T00030HRN" ;9
S SDECTMP=SDECTMP_"^T00030HOMEPHONE^T00030OFCPHONE^T00030MSGPHONE" ;12
S SDECTMP=SDECTMP_"^T00030NOK NAME^T00030RELATIONSHIP^T00030PHONE^T00030STREET^T00030CITY^T00030STATE^T00030NOK_ZIP" ;19
S SDECTMP=SDECTMP_"^D00030DATAREVIEWED" ;20
S SDECTMP=SDECTMP_"^T00030Medicare#^T00030Suffix" ;22
S SDECTMP=SDECTMP_"^T00030RegistrationComments^T00100GAF" ;24
S SDECTMP=SDECTMP_"^T00030PRACE^T00030PRACEN^T00030PETH^T00030PETHN^T00030PCOUNTRY^T00030GENDER^T00100SENSITIVE" ;31
S SDECTMP=SDECTMP_"^T00030SVCCONN^T00030SVCCONNP^T00030BADADD" ;34
;alb/sat 658 added return data
; 35 36 37 38 39 40
S SDECTMP=SDECTMP_"^T00030PADDRES2^T00030PADDRES3^T00030PCOUNTY^T00030PCELL^T00030PEMAIL^T00030PMARITAL"
; 41 42 43 44 45 46
S SDECTMP=SDECTMP_"^T00030PRELIGION^T00030PTADDRESS1^T00030PTADDRESS2^T00030PTADDRESS3^T00030PTCITY^T00030PTSTATE"
S SDECTMP=SDECTMP_"^T00030PTZIP^T00030PTZIP+4^T00030PTCOUNTRY^T00030PTCOUNTY^T00030PTSTART^T00030PTEND" ;52
; 53 54 55 56 57 58
S SDECTMP=SDECTMP_"^T00030KSTREET2^T00030KSTREET3^T00030NOK2^T00030K2NAME^T00030K2REL^T00030K2PHONE"
S SDECTMP=SDECTMP_"^T00030K2STREET^T00030K2STREET2^T00030K2STREET3^T00030K2CITY^T00030K2STATE^T00030K2ZIP" ;64
S SDECTMP=SDECTMP_"^T00500PF_FFF^T00500PF_VCD^T00500PFNATIONAL^T00500PFLOCAL^T00030SUBGRP^T00030CAT8G^T01000SIMILAR" ;71
;ajf ; adding PCP and MHP
S SDECTMP=SDECTMP_"^T00030PRIGRP^T00030PCP^T00030MHP^T00030PREFGEN^D00030PREGTIME^T00030PREFNAME"
;alb/sat 658 end additions
S ^TMP("SDEC",$J,0)=SDECTMP_$C(30)
;
S SDECY="ERROR"
I '+DFN S ^TMP("SDEC",$J,1)=$C(31) Q
I '$D(^DPT(+DFN,0)) S ^TMP("SDEC",$J,1)=$C(31) Q
S PREFGEN=$$GET1^DIQ(2,DFN_",",.024,"I")
S PREFNAME=$$GET1^DIQ(2,DFN_",",.2405,"I")
S PREREGTIMIEN=$O(^DGS(41.41,"B",DFN,"A"),-1)
I PREREGTIMIEN'="" D
. S PREREGTIM=$$FMTISO^SDAMUTDT($$GET1^DIQ(41.41,PREREGTIMIEN_",",1,"I"))
S SDECY=""
S $P(SDECY,U)=DFN
S $P(SDECY,U,23)=""
S SDECNOD=^DPT(+DFN,0)
S $P(SDECY,"^",6)=$P(SDECNOD,U) ;NAME
;S $P(SDECY,"^",8)=$P(SDECNOD,U,9) ;SSN
S $P(SDECY,"^",8)=$$LAST4SSN^SDESINPUTVALUTL(DFN) ;SSN
S Y=$P(SDECNOD,U,3) I Y]"" X ^DD("DD") S Y=$TR(Y,"@"," ")
S $P(SDECY,"^",7)=Y ;DOB
S $P(SDECY,"^",9)=""
I $D(DUZ(2)) I DUZ(2)>0 S $P(SDECY,"^",9)=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2) ;HRN
S $P(SDECY,"^",4)=$G(^DPT(+DFN,.1)) ;WARD
D MAIL
D PHONE
D NOK
D GAF
D RACELST^SDECU2(DFN,.PRACE,.PRACEN)
;S ($P(SDECY,"^",25),PRACE)=$P(SDECNOD,U,6) ;get race
S $P(SDECY,U,25)=PRACE
S $P(SDECY,U,26)=PRACEN
;S $P(SDECY,"^",26)=$S(+PRACE:$P($G(^DIC(10,PRACE,0)),U,1),1:"")
D ETH^SDECU2(DFN,.PETH,.PETHN) ;get ethnicity
S:PETH'="" $P(SDECY,"^",27)=PETH
S:PETHN'="" $P(SDECY,"^",28)=PETHN
S $P(SDECY,"^",30)=$S($P(SDECNOD,U,2)="M":"MALE",$P(SDECNOD,U,2)="F":"FEMALE",1:"")
S SDSENS=$$PTSEC^SDECUTL(DFN) S $P(SDECY,"^",31)=SDSENS
D PDEMO^SDECU3(.SDDEMO,DFN) ;alb/sat 658 PDEMO moved to SDECU3
S $P(SDECY,"^",29)=SDDEMO("PCOUNTRY")
S $P(SDECY,"^",32)=SDDEMO("SVCCONN")
S $P(SDECY,"^",33)=SDDEMO("SVCCONNP")
S $P(SDECY,"^",34)=SDDEMO("BADADD")
;D DATAREV
;D MEDICARE
;D REGCMT
;alb/sat 658 added return data
S $P(SDECY,"^",35)=SDDEMO("PADDRES2")
S $P(SDECY,"^",36)=SDDEMO("PADDRES3")
S $P(SDECY,"^",37)=SDDEMO("PCOUNTY")
S $P(SDECY,"^",38)=SDDEMO("PCELL")
S $P(SDECY,"^",39)=SDDEMO("PEMAIL")
S $P(SDECY,"^",40)=SDDEMO("PMARITAL")
S $P(SDECY,"^",41)=SDDEMO("PRELIGION")
S $P(SDECY,"^",42)=SDDEMO("PTADDRESS1")
S $P(SDECY,"^",43)=SDDEMO("PTADDRESS2")
S $P(SDECY,"^",44)=SDDEMO("PTADDRESS3")
S $P(SDECY,"^",45)=SDDEMO("PTCITY")
S $P(SDECY,"^",46)=SDDEMO("PTSTATE")
S $P(SDECY,"^",47)=SDDEMO("PTZIP")
S $P(SDECY,"^",48)=SDDEMO("PTZIP+4")
S $P(SDECY,"^",49)=SDDEMO("PTCOUNTRY")
S $P(SDECY,"^",50)=SDDEMO("PTCOUNTY")
S $P(SDECY,"^",51)=SDDEMO("PTSTART")
S $P(SDECY,"^",52)=SDDEMO("PTEND")
S $P(SDECY,"^",53)=SDDEMO("KSTREET2")
S $P(SDECY,"^",54)=SDDEMO("KSTREET3")
S $P(SDECY,"^",55)=SDDEMO("NOK2")
S $P(SDECY,"^",56)=SDDEMO("K2NAME")
S $P(SDECY,"^",57)=SDDEMO("K2REL")
S $P(SDECY,"^",58)=SDDEMO("K2PHONE")
S $P(SDECY,"^",59)=SDDEMO("K2STREET")
S $P(SDECY,"^",60)=SDDEMO("K2STREET2")
S $P(SDECY,"^",61)=SDDEMO("K2STREET3")
S $P(SDECY,"^",62)=SDDEMO("K2CITY")
S $P(SDECY,"^",63)=SDDEMO("K2STATE")
S $P(SDECY,"^",64)=SDDEMO("K2ZIP")
S $P(SDECY,"^",65)=SDDEMO("PF_FFF")
S $P(SDECY,"^",66)=SDDEMO("PF_VCD")
S $P(SDECY,"^",67)=SDDEMO("PFNATIONAL")
S $P(SDECY,"^",68)=SDDEMO("PFLOCAL")
S $P(SDECY,"^",69)=SDDEMO("SUBGRP")
S $P(SDECY,"^",70)=(SDDEMO("PRIGRP")="GROUP 8")&(SDDEMO("SUBGRP")="g")
S $P(SDECY,"^",71)=SDDEMO("SIMILAR")
S $P(SDECY,"^",72)=SDDEMO("PRIGRP")
;ajf
S SDPCP=$$OUTPTPR^SDUTL3(DFN) ;Return Primary Care Provider
S $P(SDECY,"^",73)=$P(SDPCP,"^",2)
S SDMHP=$$START^SCMCMHTC(DFN) ;Return Mental Health Provider
S $P(SDECY,"^",74)=$P(SDMHP,"^",2)
S $P(SDECY,"^",75)=$G(PREFGEN)
S $P(SDECY,"^",76)=$G(PREREGTIM)
S $P(SDECY,"^",77)=$G(PREFNAME)
;
; alb/sat 658 end additions
S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=SDECY_$C(30,31)
Q
;
GAF ;24 determine if GAF score needed
N GAF,GAFR
S GAFR=""
S GAF=$$NEWGAF^SDUTL2(DFN)
S:GAF="" GAF=-1
S $P(GAFR,"|",1)=$S(+GAF:"New GAF Required",1:"No new GAF required")
;S $P(GAFR,"|",2)=$P(GAF,U,2) ;alb/sat 658 removed 4 lines
;S $P(GAFR,"|",3)=$$FMTE^XLFDT($P(GAF,U,3))
;S $P(GAFR,"|",4)=$P(GAF,U,4)
;S $P(GAFR,"|",5)=$P($G(^VA(200,+$P(GAF,U,4),0)),U,1)
S $P(SDECY,"^",24)=GAFR
Q
;
MAIL N SDECST
NEW SDECNOD
Q:'$D(^DPT(+DFN,.11))
S SDECNOD=^DPT(+DFN,.11)
Q:SDECNOD=""
S $P(SDECY,"^",2)=$E($P(SDECNOD,U),1,50) ;STREET
S $P(SDECY,"^",3)=$P(SDECNOD,U,4) ;CITY
S SDECST=$P(SDECNOD,U,5)
I +SDECST,$D(^DIC(5,+SDECST,0)) S SDECST=$P(^DIC(5,+SDECST,0),U,2)
;S $P(SDECY,"^",4)=SDECST ;STATE
S:$L(SDECST) $P(SDECY,"^",3)=$P(SDECY,"^",3)_","_SDECST ;add ,STATE
S $P(SDECY,"^",5)=$S($P(SDECNOD,U,12)'="":$P(SDECNOD,U,12),1:$P(SDECNOD,U,6)) ;ZIP ;alb/sat 658 return zip+4 if available
;S $P(SDECY,"^",29)=$$GET1^DIQ(2,DFN_",",.1173)
Q
;
PHONE ;PHONE 10,11,12 HOME,OFC,MSG
N SDECNOD
I $D(^DPT(+DFN,.13)) D
. S SDECNOD=^DPT(+DFN,.13)
. S $P(SDECY,U,10)=$P(SDECNOD,U,1)
. S $P(SDECY,U,11)=$P(SDECNOD,U,2)
I $D(^DPT(+DFN,.121)) D
. S SDECNOD=^DPT(+DFN,.121)
. S $P(SDECY,U,12)=$P(SDECNOD,U,10)
Q
;
NOK ;NOK
; 13 NOK NAME^RELATIONSHIP^PHONE^STREET^CITY^STATE^ZIP
N Y,SDECST,SDECNOD
I $D(^DPT(+DFN,.21)) D
. S SDECNOD=^DPT(+DFN,.21)
. S $P(SDECY,U,13)=$P(SDECNOD,U,1)
. S $P(SDECY,U,14)="" ;$$VAL^SDECDIQ1(9000001,DFN,2802)
. S $P(SDECY,U,15)=$P(SDECNOD,U,9)
. S $P(SDECY,U,16)=$P(SDECNOD,U,3)
. S $P(SDECY,U,17)=$P(SDECNOD,U,6)
. S SDECST=$P(SDECNOD,U,7)
. I +SDECST D
. . I $D(^DIC(5,+SDECST,0)) S SDECST=$P(^DIC(5,+SDECST,0),U,2),$P(SDECY,U,18)=SDECST
. S $P(SDECY,U,19)=$P(SDECNOD,U,8)
Q
;
DATAREV Q S $P(SDECY,U,20)="" ;$P($$VAL^SDECDIQ1(9000001,DFN,16651),"@")
Q
;
REGCMT N SDECI,SDECM,SDECR
Q
S SDECR=""
D ENP^SDECDIQ1(9000001,DFN,1301,"SDECM(")
S SDECI=0 F S SDECI=$O(SDECM(1301,SDECI)) Q:'+SDECI D
. S SDECR=SDECR_" "_SDECM(1301,SDECI)
S $P(SDECY,U,23)=$TR($E(SDECR,1,1024),U," ") ; MJL 1/17/2007
Q
;
MEDICARE ;
S $P(SDECY,U,21)="" ;$$VAL^SDECDIQ1(9000003,DFN,.03)
S $P(SDECY,U,22)="" ;$$VAL^SDECDIQ1(9000003,DFN,.04)
Q
;
GETMCARE(SDECY,DFN) ;
;Returns IEN^MEDICARE#^SUFFIX^SUBENTRY#^TYPE^ELIG.BEGIN^ELIG.END |
;File is dinum
;
Q
N ASDGX,C,N,SDECNUM,SDECSUF,SDECBLD
S SDECNUM=$$VAL^SDECDIQ1(9000003,DFN,.03)
S SDECSUF=$$VAL^SDECDIQ1(9000003,DFN,.04)
D ENPM^SDECDIQ1(9000003.11,DFN_",0",".01:.03","ASDGX(")
S C=1,N=0,SDECBLD=""
F S N=$O(ASDGX(N)) Q:'N D
. S $P(SDECY,"|",C)=DFN_U_SDECNUM_U_SDECSUF_U_N_U_ASDGX(N,.03)_U_ASDGX(N,.01)_U_ASDGX(N,.02)
. S C=C+1
. Q
Q
;
GETPVTIN(SDECY,DFN) ;
;Returns IEN^SUBENTRY^INSURER^POLICYNUMBER^ELIG.BEGIN^ELIG.END|...
;File is dinum
;
Q
N ASDGX,C,N
D ENPM^SDECDIQ1(9000006.11,DFN_",0",".01;.02;.06;.07","ASDGX(")
S C=1,N=0
F S N=$O(ASDGX(N)) Q:'N D
. S $P(SDECY,"|",C)=DFN_U_N_U_ASDGX(N,.01)_U_ASDGX(N,.02)_U_ASDGX(N,.06)_U_ASDGX(N,.07)
. S C=C+1
. Q
Q
;
DFN(FILE,DFN) ; -- returns ien for file
Q ""
I FILE'[9000004 Q DFN
Q +$O(^AUPNMCD("B",DFN,0))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDEC09 14922 printed Dec 13, 2024@02:50:04 Page 2
SDEC09 ;ALB/SAT/LAB - VISTA SCHEDULING RPCS ;JUL 26,2022
+1 ;;5.3;Scheduling;**627,642,658,679,801,809,823**;Aug 13, 1993;Build 9
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 ; Reference to ^DPT in ICR #10035
+5 ; Reference to ^DGS(41.41 in ICR #4425
+6 ;
+7 QUIT
+8 ;
+9 ;
GETREGA(SDECRET,DFN) ;return basic reg info/demographics for given patient
+1 ;GETREGA(SDECRET,DFN) external parameter tag is in SDEC
+2 ;DFN - Patient ID - Pointer to PATIENT file
+3 ;Returns IEN^STREET^CITY^STATE^ZIP^NAME^DOB^SSN^HRN
+4 ; 10 HOMEPHONE - Residence or Phone #1
+5 ; 11 OFCPHONE - Office/Work Phone
+6 ; 12 MSGPHONE - Also referred to as Phone #2 and Temporary Phone number
+7 ; 13 NOK NAME^RELATIONSHIP^PHONE^STREET^CITY^STATE^NOK_ZIP
+8 ; 20 DATAREVIEWED^
+9 ; 21 Medicare#^Suffix
+10 ; 23 RegistrationComments
+11 ; 24 GAF - <text> | <GAF score> | <GAF date> | <diagnosis by IEN> | <diagnosis by name>
+12 ; 25 PRACE - Patient Race pointer to RACE file 10 | separates entries
+13 ; 26 PRACEN - Patient Race name from RACE file | separates entries
+14 ; 27 PETH - Patient Ethnicity list separated by pipe |
+15 ; Pointer to ETHNICITY file 10.2
+16 ; 28 PETHN - Patient Ethnicity names separated by pipe |
+17 ; 29 PCOUNTRY - Country pointer to COUNTRY CODE file
+18 ; 30 GENDER - Patient Gender - valid values are MALE FEMALE
+19 ; 31 SENSITIVE - Sensitive Record Access data separated by pipe |:
+20 ; 1. return code:
+21 ; -1-RPC/API failed
+22 ; Required variable not defined
+23 ; 0-No display/action required
+24 ; Not accessing own, employee, or sensitive record
+25 ; 1-Display warning message
+26 ; Sensitive and DG SENSITIVITY key holder
+27 ; or Employee and DG SECURITY OFFICER key holder
+28 ; 2-Display warning message/require OK to continue
+29 ; Sensitive and not a DG SENSITIVITY key holder
+30 ; Employee and not a DG SECURITY OFFICER key holder
+31 ; 3-Access to record denied
+32 ; Accessing own record
+33 ; 4-Access to Patient (#2) file records denied
+34 ; SSN not defined
+35 ; 2. display text/message
+36 ; 3. display text/message
+37 ; 4. display text/message
+38 ; 32 SVCCONN - Patient's Service Connected status
+39 ; YES NO
+40 ; 33 SVCCONNP - Patient's Service Connected Percentage
+41 ; Numeric 0-100
+42 ; 34 BADADD - BAD ADDRESS INDICATOR
+43 ; 1=UNDELIVERABLE
+44 ; 2=HOMELESS
+45 ; 3=OTHER
+46 ; 4=ADDRESS NOT FOUND
+47 ; 35. PADDRES2 - Patient Street Address line 2
+48 ; 36. PADDRES3 - Patient Street Address line 3
+49 ; 37. PCOUNTY - Patient's County
+50 ; 38. PCELL - Patient's Cell Phone
+51 ; 39. PEMAIL - Patient's Email address
+52 ; 40. PMARITAL - Patient Marital Status
+53 ; 41. PRELIGION - Patient Religious Preference
+54 ; 42. PTADDRESS1 - Patient Temporary Address Line 1 (.1211)
+55 ; 43. PTADDRESS2 - Patient Temporary Address Line 2 (.1212)
+56 ; 44. PTADDRESS3 - Patient Temporary Address Line 3 (.1213)
+57 ; 45. PTCITY - Patient Temporary City (.1214)
+58 ; 46. PTSTATE - Patient Temporary State (.1215)
+59 ; 47. PTZIP - Patient Temporary Zip (.1216)
+60 ; 48. PTZIP+4 - Patient Temporary Zip+4 (.12112)
+61 ; 49. PTCOUNTRY - Patient Temporary Country (.1223)
+62 ; 50. PTCOUNTY - Patient Temporary County (.12111)
+63 ; 51. PTSTART - Patient Temporary Address Start Date (.1217)
+64 ; 52. PTEND - Patient Temporary Address End Date (.1218)
+65 ; 53. KSTREET2 - Primary Next of Kin Street Address [Line 2] (.214)
+66 ; 54. KSTREET3 - Primary Next of Kin Street Address [Line 3] (.215)
+67 ; 55. NOK2 - Secondary Next of Kin (.2191)
+68 ; 56. K2NAME - Secondary Next of Kin name (.2191)
+69 ; 57. K2REL - Secondary Next of Kin Relationship to Patient (.2192)
+70 ; 58. K2PHONE - Secondary Next of Kin Phone (.2199)
+71 ; 59. K2STREET - Secondary Next of Kin Street Address [Line 1] (.2193)
+72 ; 60. K2STREET2 - Secondary Next of Kin Street Address [Line 2] (.2194)
+73 ; 61. K2STREET3 - Secondary Next of Kin Street Address [Line 3] (.2195)
+74 ; 62. K2CITY - Secondary Next of Kin City (.2196)
+75 ; 63. K2STATE - Secondary Next of Kin State (.2197)
+76 ; 64. K2ZIP - Secondary Next of Kin Zip (.2198)
+77 ; 65. PF_FFF - Patient FUGITIVE FELON FLAG 1=YES
+78 ; 66. PF_VCD - Patient VETERAN CATASTROPHICALLY DISABLED? Y=YES N=NO
+79 ; 67. PFNATIONAL - Patient national Flags (PRF ASSIGNMENT/PRF NATIONAL FLAG) separated by ^
+80 ; Each ^ piece contains the following | pipe pieces:
+81 ; 1. PRFAID - PRF Assignment ID pointer to PRF ASSIGNMENT file (#26.13)
+82 ; 2. PRFSTAT - PRF Assignment Status 0=INACTIVE 1=ACTIVE
+83 ; 3. PRFNID - PRF National Flag ID pointer to PRF NATIONAL FLAG file (#26.15)
+84 ; 4. PRFNNAME - PRF National Flag name
+85 ; 5. PRFNSTAT - PRF National Flag status 0=INACTIVE 1=ACTIVE
+86 ; 68. PFLOCAL - Patient Local Flags (PRF ASSIGNMENT/PRF Local FLAG) separated by ^
+87 ; Each ^ piece contains the following | pipe pieces:
+88 ; 1. PRFAID - PRF Assignment ID pointer to PRF ASSIGNMENT file (#26.13)
+89 ; 2. PRFSTAT - PRF Assignment Status 0=INACTIVE 1=ACTIVE
+90 ; 3. PRFLID - PRF Local Flag ID pointer to PRF LOCAL FLAG file (#26.11)
+91 ; 4. PRFLNAME - PRF Local Flag name
+92 ; 5. PRFLSTAT - PRF Local Flag status 0=INACTIVE 1=ACTIVE
+93 ; 72. PRIGRP - Patient Enrollment Priority Group
+94 ; 73. PCP
+95 ; 74. MHP
+96 ; 75. PREFGEN - Patient Self Identified Gender
+97 ; 76. PREREGTIM- Preregistration time stamp
+98 ; 77. PREFNAME - Preferred Name
+99 ;For patient with ien DFN
+100 ;K ^TMP("SDEC",$J)
+101 NEW SDDEMO,SDECI,SDECNOD,SDECNAM,SDECTMP,SDSENS,Y,PREFGEN
+102 NEW PRACE,PRACEN,PETH,PETHN,PCOUNTRY,SVCCONN,SVCCONNP,SDPCP,SDMHP,PREREGTIMIEN,PREREGTIM,PREFNAME
+103 SET SDECRET="^TMP(""SDEC"","_$JOB_")"
+104 KILL @SDECRET
+105 SET SDECI=0
+106 ;
+107 ;9
SET SDECTMP="T00030IEN^T00030STREET^T00030CITY/STATE^T00030WARD:^T00030ZIP^T00030NAME^D00030DOB^T00030SSN^T00030HRN"
+108 ;12
SET SDECTMP=SDECTMP_"^T00030HOMEPHONE^T00030OFCPHONE^T00030MSGPHONE"
+109 ;19
SET SDECTMP=SDECTMP_"^T00030NOK NAME^T00030RELATIONSHIP^T00030PHONE^T00030STREET^T00030CITY^T00030STATE^T00030NOK_ZIP"
+110 ;20
SET SDECTMP=SDECTMP_"^D00030DATAREVIEWED"
+111 ;22
SET SDECTMP=SDECTMP_"^T00030Medicare#^T00030Suffix"
+112 ;24
SET SDECTMP=SDECTMP_"^T00030RegistrationComments^T00100GAF"
+113 ;31
SET SDECTMP=SDECTMP_"^T00030PRACE^T00030PRACEN^T00030PETH^T00030PETHN^T00030PCOUNTRY^T00030GENDER^T00100SENSITIVE"
+114 ;34
SET SDECTMP=SDECTMP_"^T00030SVCCONN^T00030SVCCONNP^T00030BADADD"
+115 ;alb/sat 658 added return data
+116 ; 35 36 37 38 39 40
+117 SET SDECTMP=SDECTMP_"^T00030PADDRES2^T00030PADDRES3^T00030PCOUNTY^T00030PCELL^T00030PEMAIL^T00030PMARITAL"
+118 ; 41 42 43 44 45 46
+119 SET SDECTMP=SDECTMP_"^T00030PRELIGION^T00030PTADDRESS1^T00030PTADDRESS2^T00030PTADDRESS3^T00030PTCITY^T00030PTSTATE"
+120 ;52
SET SDECTMP=SDECTMP_"^T00030PTZIP^T00030PTZIP+4^T00030PTCOUNTRY^T00030PTCOUNTY^T00030PTSTART^T00030PTEND"
+121 ; 53 54 55 56 57 58
+122 SET SDECTMP=SDECTMP_"^T00030KSTREET2^T00030KSTREET3^T00030NOK2^T00030K2NAME^T00030K2REL^T00030K2PHONE"
+123 ;64
SET SDECTMP=SDECTMP_"^T00030K2STREET^T00030K2STREET2^T00030K2STREET3^T00030K2CITY^T00030K2STATE^T00030K2ZIP"
+124 ;71
SET SDECTMP=SDECTMP_"^T00500PF_FFF^T00500PF_VCD^T00500PFNATIONAL^T00500PFLOCAL^T00030SUBGRP^T00030CAT8G^T01000SIMILAR"
+125 ;ajf ; adding PCP and MHP
+126 SET SDECTMP=SDECTMP_"^T00030PRIGRP^T00030PCP^T00030MHP^T00030PREFGEN^D00030PREGTIME^T00030PREFNAME"
+127 ;alb/sat 658 end additions
+128 SET ^TMP("SDEC",$JOB,0)=SDECTMP_$CHAR(30)
+129 ;
+130 SET SDECY="ERROR"
+131 IF '+DFN
SET ^TMP("SDEC",$JOB,1)=$CHAR(31)
QUIT
+132 IF '$DATA(^DPT(+DFN,0))
SET ^TMP("SDEC",$JOB,1)=$CHAR(31)
QUIT
+133 SET PREFGEN=$$GET1^DIQ(2,DFN_",",.024,"I")
+134 SET PREFNAME=$$GET1^DIQ(2,DFN_",",.2405,"I")
+135 SET PREREGTIMIEN=$ORDER(^DGS(41.41,"B",DFN,"A"),-1)
+136 IF PREREGTIMIEN'=""
Begin DoDot:1
+137 SET PREREGTIM=$$FMTISO^SDAMUTDT($$GET1^DIQ(41.41,PREREGTIMIEN_",",1,"I"))
End DoDot:1
+138 SET SDECY=""
+139 SET $PIECE(SDECY,U)=DFN
+140 SET $PIECE(SDECY,U,23)=""
+141 SET SDECNOD=^DPT(+DFN,0)
+142 ;NAME
SET $PIECE(SDECY,"^",6)=$PIECE(SDECNOD,U)
+143 ;S $P(SDECY,"^",8)=$P(SDECNOD,U,9) ;SSN
+144 ;SSN
SET $PIECE(SDECY,"^",8)=$$LAST4SSN^SDESINPUTVALUTL(DFN)
+145 SET Y=$PIECE(SDECNOD,U,3)
IF Y]""
XECUTE ^DD("DD")
SET Y=$TRANSLATE(Y,"@"," ")
+146 ;DOB
SET $PIECE(SDECY,"^",7)=Y
+147 SET $PIECE(SDECY,"^",9)=""
+148 ;HRN
IF $DATA(DUZ(2))
IF DUZ(2)>0
SET $PIECE(SDECY,"^",9)=$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
+149 ;WARD
SET $PIECE(SDECY,"^",4)=$GET(^DPT(+DFN,.1))
+150 DO MAIL
+151 DO PHONE
+152 DO NOK
+153 DO GAF
+154 DO RACELST^SDECU2(DFN,.PRACE,.PRACEN)
+155 ;S ($P(SDECY,"^",25),PRACE)=$P(SDECNOD,U,6) ;get race
+156 SET $PIECE(SDECY,U,25)=PRACE
+157 SET $PIECE(SDECY,U,26)=PRACEN
+158 ;S $P(SDECY,"^",26)=$S(+PRACE:$P($G(^DIC(10,PRACE,0)),U,1),1:"")
+159 ;get ethnicity
DO ETH^SDECU2(DFN,.PETH,.PETHN)
+160 if PETH'=""
SET $PIECE(SDECY,"^",27)=PETH
+161 if PETHN'=""
SET $PIECE(SDECY,"^",28)=PETHN
+162 SET $PIECE(SDECY,"^",30)=$SELECT($PIECE(SDECNOD,U,2)="M":"MALE",$PIECE(SDECNOD,U,2)="F":"FEMALE",1:"")
+163 SET SDSENS=$$PTSEC^SDECUTL(DFN)
SET $PIECE(SDECY,"^",31)=SDSENS
+164 ;alb/sat 658 PDEMO moved to SDECU3
DO PDEMO^SDECU3(.SDDEMO,DFN)
+165 SET $PIECE(SDECY,"^",29)=SDDEMO("PCOUNTRY")
+166 SET $PIECE(SDECY,"^",32)=SDDEMO("SVCCONN")
+167 SET $PIECE(SDECY,"^",33)=SDDEMO("SVCCONNP")
+168 SET $PIECE(SDECY,"^",34)=SDDEMO("BADADD")
+169 ;D DATAREV
+170 ;D MEDICARE
+171 ;D REGCMT
+172 ;alb/sat 658 added return data
+173 SET $PIECE(SDECY,"^",35)=SDDEMO("PADDRES2")
+174 SET $PIECE(SDECY,"^",36)=SDDEMO("PADDRES3")
+175 SET $PIECE(SDECY,"^",37)=SDDEMO("PCOUNTY")
+176 SET $PIECE(SDECY,"^",38)=SDDEMO("PCELL")
+177 SET $PIECE(SDECY,"^",39)=SDDEMO("PEMAIL")
+178 SET $PIECE(SDECY,"^",40)=SDDEMO("PMARITAL")
+179 SET $PIECE(SDECY,"^",41)=SDDEMO("PRELIGION")
+180 SET $PIECE(SDECY,"^",42)=SDDEMO("PTADDRESS1")
+181 SET $PIECE(SDECY,"^",43)=SDDEMO("PTADDRESS2")
+182 SET $PIECE(SDECY,"^",44)=SDDEMO("PTADDRESS3")
+183 SET $PIECE(SDECY,"^",45)=SDDEMO("PTCITY")
+184 SET $PIECE(SDECY,"^",46)=SDDEMO("PTSTATE")
+185 SET $PIECE(SDECY,"^",47)=SDDEMO("PTZIP")
+186 SET $PIECE(SDECY,"^",48)=SDDEMO("PTZIP+4")
+187 SET $PIECE(SDECY,"^",49)=SDDEMO("PTCOUNTRY")
+188 SET $PIECE(SDECY,"^",50)=SDDEMO("PTCOUNTY")
+189 SET $PIECE(SDECY,"^",51)=SDDEMO("PTSTART")
+190 SET $PIECE(SDECY,"^",52)=SDDEMO("PTEND")
+191 SET $PIECE(SDECY,"^",53)=SDDEMO("KSTREET2")
+192 SET $PIECE(SDECY,"^",54)=SDDEMO("KSTREET3")
+193 SET $PIECE(SDECY,"^",55)=SDDEMO("NOK2")
+194 SET $PIECE(SDECY,"^",56)=SDDEMO("K2NAME")
+195 SET $PIECE(SDECY,"^",57)=SDDEMO("K2REL")
+196 SET $PIECE(SDECY,"^",58)=SDDEMO("K2PHONE")
+197 SET $PIECE(SDECY,"^",59)=SDDEMO("K2STREET")
+198 SET $PIECE(SDECY,"^",60)=SDDEMO("K2STREET2")
+199 SET $PIECE(SDECY,"^",61)=SDDEMO("K2STREET3")
+200 SET $PIECE(SDECY,"^",62)=SDDEMO("K2CITY")
+201 SET $PIECE(SDECY,"^",63)=SDDEMO("K2STATE")
+202 SET $PIECE(SDECY,"^",64)=SDDEMO("K2ZIP")
+203 SET $PIECE(SDECY,"^",65)=SDDEMO("PF_FFF")
+204 SET $PIECE(SDECY,"^",66)=SDDEMO("PF_VCD")
+205 SET $PIECE(SDECY,"^",67)=SDDEMO("PFNATIONAL")
+206 SET $PIECE(SDECY,"^",68)=SDDEMO("PFLOCAL")
+207 SET $PIECE(SDECY,"^",69)=SDDEMO("SUBGRP")
+208 SET $PIECE(SDECY,"^",70)=(SDDEMO("PRIGRP")="GROUP 8")&(SDDEMO("SUBGRP")="g")
+209 SET $PIECE(SDECY,"^",71)=SDDEMO("SIMILAR")
+210 SET $PIECE(SDECY,"^",72)=SDDEMO("PRIGRP")
+211 ;ajf
+212 ;Return Primary Care Provider
SET SDPCP=$$OUTPTPR^SDUTL3(DFN)
+213 SET $PIECE(SDECY,"^",73)=$PIECE(SDPCP,"^",2)
+214 ;Return Mental Health Provider
SET SDMHP=$$START^SCMCMHTC(DFN)
+215 SET $PIECE(SDECY,"^",74)=$PIECE(SDMHP,"^",2)
+216 SET $PIECE(SDECY,"^",75)=$GET(PREFGEN)
+217 SET $PIECE(SDECY,"^",76)=$GET(PREREGTIM)
+218 SET $PIECE(SDECY,"^",77)=$GET(PREFNAME)
+219 ;
+220 ; alb/sat 658 end additions
+221 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=SDECY_$CHAR(30,31)
+222 QUIT
+223 ;
GAF ;24 determine if GAF score needed
+1 NEW GAF,GAFR
+2 SET GAFR=""
+3 SET GAF=$$NEWGAF^SDUTL2(DFN)
+4 if GAF=""
SET GAF=-1
+5 SET $PIECE(GAFR,"|",1)=$SELECT(+GAF:"New GAF Required",1:"No new GAF required")
+6 ;S $P(GAFR,"|",2)=$P(GAF,U,2) ;alb/sat 658 removed 4 lines
+7 ;S $P(GAFR,"|",3)=$$FMTE^XLFDT($P(GAF,U,3))
+8 ;S $P(GAFR,"|",4)=$P(GAF,U,4)
+9 ;S $P(GAFR,"|",5)=$P($G(^VA(200,+$P(GAF,U,4),0)),U,1)
+10 SET $PIECE(SDECY,"^",24)=GAFR
+11 QUIT
+12 ;
MAIL NEW SDECST
+1 NEW SDECNOD
+2 if '$DATA(^DPT(+DFN,.11))
QUIT
+3 SET SDECNOD=^DPT(+DFN,.11)
+4 if SDECNOD=""
QUIT
+5 ;STREET
SET $PIECE(SDECY,"^",2)=$EXTRACT($PIECE(SDECNOD,U),1,50)
+6 ;CITY
SET $PIECE(SDECY,"^",3)=$PIECE(SDECNOD,U,4)
+7 SET SDECST=$PIECE(SDECNOD,U,5)
+8 IF +SDECST
IF $DATA(^DIC(5,+SDECST,0))
SET SDECST=$PIECE(^DIC(5,+SDECST,0),U,2)
+9 ;S $P(SDECY,"^",4)=SDECST ;STATE
+10 ;add ,STATE
if $LENGTH(SDECST)
SET $PIECE(SDECY,"^",3)=$PIECE(SDECY,"^",3)_","_SDECST
+11 ;ZIP ;alb/sat 658 return zip+4 if available
SET $PIECE(SDECY,"^",5)=$SELECT($PIECE(SDECNOD,U,12)'="":$PIECE(SDECNOD,U,12),1:$PIECE(SDECNOD,U,6))
+12 ;S $P(SDECY,"^",29)=$$GET1^DIQ(2,DFN_",",.1173)
+13 QUIT
+14 ;
PHONE ;PHONE 10,11,12 HOME,OFC,MSG
+1 NEW SDECNOD
+2 IF $DATA(^DPT(+DFN,.13))
Begin DoDot:1
+3 SET SDECNOD=^DPT(+DFN,.13)
+4 SET $PIECE(SDECY,U,10)=$PIECE(SDECNOD,U,1)
+5 SET $PIECE(SDECY,U,11)=$PIECE(SDECNOD,U,2)
End DoDot:1
+6 IF $DATA(^DPT(+DFN,.121))
Begin DoDot:1
+7 SET SDECNOD=^DPT(+DFN,.121)
+8 SET $PIECE(SDECY,U,12)=$PIECE(SDECNOD,U,10)
End DoDot:1
+9 QUIT
+10 ;
NOK ;NOK
+1 ; 13 NOK NAME^RELATIONSHIP^PHONE^STREET^CITY^STATE^ZIP
+2 NEW Y,SDECST,SDECNOD
+3 IF $DATA(^DPT(+DFN,.21))
Begin DoDot:1
+4 SET SDECNOD=^DPT(+DFN,.21)
+5 SET $PIECE(SDECY,U,13)=$PIECE(SDECNOD,U,1)
+6 ;$$VAL^SDECDIQ1(9000001,DFN,2802)
SET $PIECE(SDECY,U,14)=""
+7 SET $PIECE(SDECY,U,15)=$PIECE(SDECNOD,U,9)
+8 SET $PIECE(SDECY,U,16)=$PIECE(SDECNOD,U,3)
+9 SET $PIECE(SDECY,U,17)=$PIECE(SDECNOD,U,6)
+10 SET SDECST=$PIECE(SDECNOD,U,7)
+11 IF +SDECST
Begin DoDot:2
+12 IF $DATA(^DIC(5,+SDECST,0))
SET SDECST=$PIECE(^DIC(5,+SDECST,0),U,2)
SET $PIECE(SDECY,U,18)=SDECST
End DoDot:2
+13 SET $PIECE(SDECY,U,19)=$PIECE(SDECNOD,U,8)
End DoDot:1
+14 QUIT
+15 ;
DATAREV ;$P($$VAL^SDECDIQ1(9000001,DFN,16651),"@")
QUIT
SET $PIECE(SDECY,U,20)=""
+1 QUIT
+2 ;
REGCMT NEW SDECI,SDECM,SDECR
+1 QUIT
+2 SET SDECR=""
+3 DO ENP^SDECDIQ1(9000001,DFN,1301,"SDECM(")
+4 SET SDECI=0
FOR
SET SDECI=$ORDER(SDECM(1301,SDECI))
if '+SDECI
QUIT
Begin DoDot:1
+5 SET SDECR=SDECR_" "_SDECM(1301,SDECI)
End DoDot:1
+6 ; MJL 1/17/2007
SET $PIECE(SDECY,U,23)=$TRANSLATE($EXTRACT(SDECR,1,1024),U," ")
+7 QUIT
+8 ;
MEDICARE ;
+1 ;$$VAL^SDECDIQ1(9000003,DFN,.03)
SET $PIECE(SDECY,U,21)=""
+2 ;$$VAL^SDECDIQ1(9000003,DFN,.04)
SET $PIECE(SDECY,U,22)=""
+3 QUIT
+4 ;
GETMCARE(SDECY,DFN) ;
+1 ;Returns IEN^MEDICARE#^SUFFIX^SUBENTRY#^TYPE^ELIG.BEGIN^ELIG.END |
+2 ;File is dinum
+3 ;
+4 QUIT
+5 NEW ASDGX,C,N,SDECNUM,SDECSUF,SDECBLD
+6 SET SDECNUM=$$VAL^SDECDIQ1(9000003,DFN,.03)
+7 SET SDECSUF=$$VAL^SDECDIQ1(9000003,DFN,.04)
+8 DO ENPM^SDECDIQ1(9000003.11,DFN_",0",".01:.03","ASDGX(")
+9 SET C=1
SET N=0
SET SDECBLD=""
+10 FOR
SET N=$ORDER(ASDGX(N))
if 'N
QUIT
Begin DoDot:1
+11 SET $PIECE(SDECY,"|",C)=DFN_U_SDECNUM_U_SDECSUF_U_N_U_ASDGX(N,.03)_U_ASDGX(N,.01)_U_ASDGX(N,.02)
+12 SET C=C+1
+13 QUIT
End DoDot:1
+14 QUIT
+15 ;
GETPVTIN(SDECY,DFN) ;
+1 ;Returns IEN^SUBENTRY^INSURER^POLICYNUMBER^ELIG.BEGIN^ELIG.END|...
+2 ;File is dinum
+3 ;
+4 QUIT
+5 NEW ASDGX,C,N
+6 DO ENPM^SDECDIQ1(9000006.11,DFN_",0",".01;.02;.06;.07","ASDGX(")
+7 SET C=1
SET N=0
+8 FOR
SET N=$ORDER(ASDGX(N))
if 'N
QUIT
Begin DoDot:1
+9 SET $PIECE(SDECY,"|",C)=DFN_U_N_U_ASDGX(N,.01)_U_ASDGX(N,.02)_U_ASDGX(N,.06)_U_ASDGX(N,.07)
+10 SET C=C+1
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
DFN(FILE,DFN) ; -- returns ien for file
+1 QUIT ""
+2 IF FILE'[9000004
QUIT DFN
+3 QUIT +$ORDER(^AUPNMCD("B",DFN,0))
