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

DPTLK7.m

Go to the documentation of this file.
  1. DPTLK7 ;OAK/ELZ,ARF - MAS PATIENT LOOKUP ENTERPRISE SEARCH ;15 May 2020 2:31 PM
  1. ;;5.3;Registration;**915,919,926,967,981,1000,1024,1111**;Aug 13, 1993;Build 18
  1. ;
  1. ; DGX is what the user originally entered, name is assumed unless it
  1. ; is exactly 9 digits, DON'T pass by reference it may change
  1. ; Return: DFN (new or found locally), 0 if nothing found/added
  1. ;
  1. N DG20NAME,DGMPI,DGFLDS,DGOUT,%,%Y,DGMPIR,DGDFN,DGMPIICN,DGSAVE
  1. N DGKEYREQ,X,DA,DO,DIC,DGADDREQ,DGMCID
  1. Q:$G(DGSEARCH) 0
  1. S (DGKEYREQ,DGOUT,DGADDREQ)=0,DGSEARCH=1,DGSAVE=DGX
  1. Q:$T(PATIENT^MPIFXMLP)="" 0
  1. ;
  1. YN ;Enterprise Search?
  1. W !,"Do you want to do an Enterprise Search"
  1. D YN^DICN I %=0 W !,"You must enter Yes or No." G YN
  1. Q:%'=1 0
  1. ;
  1. I $G(DGXOLD)]"" S DGX=DGXOLD
  1. ; if yes then ask questions
  1. ; if 9 digits entered assume ssn, need to save
  1. PROMPT I DGX?9N S DGFLDS(.09)=DGX,DGX=""
  1. ; if name in "" need to remove
  1. I $E(DGX,1)="""" S DGX=$E(DGX,2,99)
  1. I $E(DGX,$L(DGX))="""" S DGX=$E(DGX,1,$L(DGX)-1)
  1. D NAME(.DGX,.DG20NAME,.DGOUT) Q:DGOUT 0
  1. D FLDS(.DGFLDS,DG20NAME,.DGOUT) Q:DGOUT 0
  1. I $G(DGFLDS(.09))'?9N S DGADDREQ=1
  1. D:DGADDREQ ADDRESS(.DGFLDS,.DGOUT) Q:DGOUT 0
  1. I DGADDREQ,'$$ADDREQ(.DGFLDS) D G PROMPT
  1. . W !,"You must enter an actual SSN, a COMPLETE Address or Phone to search.",!
  1. . K DGX,DG20NAME,DGFLDS,DGMPI,DGMPIR
  1. . S DGX=DGSAVE
  1. ;
  1. ; call MPI to get data
  1. W !!,"Searching the MVI..."
  1. D FORMAT(.DGMPI,.DG20NAME,.DGFLDS)
  1. D PATIENT^MPIFXMLP(.DGMPIR,.DGMPI)
  1. S DGMCID=$G(DGMPIR("mcid"))
  1. ;
  1. ; too many matches found, they need to get the numbers down, re-prompt
  1. I $G(DGMPIR("count"))>10!($G(DGMPIR("Result"))="QE") D G PROMPT
  1. . W !,$S(DGMPIR("count")>10:DGMPIR("count"),1:"Too many")," records found, you need to provide more specific criteria.",!
  1. . K DGX,DG20NAME,DGFLDS,DGMPI,DGMPIR
  1. . S DGX=DGSAVE
  1. ;
  1. ; no matches found on the MPI offer to add
  1. I '$G(DGMPIR("count")) W !,"No records found on the MVI.",! D Q DGDFN
  1. . S DPTX=$G(DGFLDS(.01)) D ASKADD^DPTLK2 I DPTDFN'>0 S DGDFN=0 Q
  1. . S DGDFN=$$ADD(.DGFLDS,.DG20NAME) Q:'DGDFN
  1. . ;
  1. . ; setup DGMPIR since there was nothing
  1. . M DGMPIR(1)=DGMPI
  1. . S DGMPIR(+$O(DGMPIR(0)),"DFN")=DGDFN
  1. . ;
  1. . S DGMPIR("mcid")=DGMCID
  1. .;**981 - Story 841885 (ckn)
  1. . S DGMPIR("SelIdentifier")=""
  1. . D MPIADD(.DGMPIR)
  1. ;
  1. ; do I have some records that are in autolink threshold? - key required
  1. S X=0 F S X=$O(DGMPIR(X)) Q:'X I $G(DGMPIR(X,"Score"))'<$G(DGMPIR("matchThreshold")) S DGKEYREQ=1
  1. ;
  1. ; preset list to select patients
  1. S DGDFN=$$ENP^MPIFVER(.DGMPIR,$G(DGMPIR("matchThreshold")),$G(DGMPIR("dupeThreshold")))
  1. ;
  1. ; found and selected local patient
  1. I DGDFN>0 Q DGDFN
  1. I DGDFN=-1 S DPTX="" Q 0
  1. ;
  1. ; need to add new patient based on return from selection
  1. I $D(DGMPIR)>1 K DG20NAME D FORMATR(.DGFLDS,.DGMPIR,.DG20NAME) S DGDFN=$$ADD(.DGFLDS,.DG20NAME) D:DGDFN G QUIT
  1. . ;
  1. . S DGMPIR(+$O(DGMPIR(0)),"DFN")=DGDFN
  1. . ;
  1. . S DGMPIR("mcid")=DGMCID
  1. .;**981 - Story 841885 (ckn)
  1. . I $G(DGMPIR(1,"ICN"))'="" S DGMPIR("SelIdentifier")=DGMPIR(1,"ICN")_"^NI^200M^USVHA"
  1. . ;**1024,Story 1258907 (mko): The TFs are now also returned in "IDS"; Look for the DoD record, but only if ICN is not set
  1. . ;I $G(DGMPIR(1,"IDS",1,"ID"))'="" S DGMPIR("SelIdentifier")=DGMPIR(1,"IDS",1,"ID")_"^NI^200DOD^USDOD"
  1. . E N I S I="" F S I=$O(DGMPIR(1,"IDS",I)) Q:I="" I $G(DGMPIR(1,"IDS",I,"ID"))]"",$G(DGMPIR(1,"IDS",I,"ISSUER"))="USDOD",$G(DGMPIR(1,"IDS",I,"SOURCE"))="200DOD" S DGMPIR("SelIdentifier")=DGMPIR(1,"IDS",I,"ID")_"^NI^200DOD^USDOD" Q
  1. . D MPIADD(.DGMPIR)
  1. . W !
  1. . ;
  1. . ; if known to ESR, send Z11 and monitor for return data
  1. . I $G(DGMPIR(1,"Z11")) D
  1. .. W !,"Adding site correlation to MVI "
  1. .. N DGTIME,DGQRY,DGDONE,DGQSTAT
  1. .. S (DGQSTAT,DGDONE)=0
  1. .. F DGTIME=1:1:60 D
  1. ... I $D(^XTMP("DPTLK7 A24 IN-PROCESS",DGDFN)) W "." H 1 Q
  1. ... ;
  1. ... ; not sending, maybe already sent or it is turned off
  1. ... I 'DGDONE S DGDONE=1 D W "." H 1 Q
  1. .... I $$QRY^DGENQRY(DGDFN) W !,"Enrollment/Eligibility Query processing "
  1. ... ;
  1. ... ; check for status until it is returned, end with set to 60 seconds
  1. ... S DGQRY=$$GET^DGENQRY($$FINDLAST^DGENQRY($G(DGDFN)),.DGQRY) I $G(DGQRY("STATUS"))>2 S DGTIME=60,DGQSTAT=1 Q
  1. ... W "." H 1
  1. .. I 'DGQSTAT D
  1. ... W !,"Query to ES timed out, proceeding with registration."
  1. ... W !,"The data will be uploaded when received."
  1. .. W !!
  1. ;
  1. ; no one selected but may still need to add based on traits entered
  1. I DGKEYREQ,'$D(^XUSEC("DG MVI ADD PT",DUZ)) D
  1. . W !,"The search returned one or more patients above the Auto-Link threshold,"
  1. . W !,"none of them selected. Security key required to add without selection."
  1. E D
  1. . N DPTDFN,DPTX,Y,%,%Y,DGMPIR
  1. . M DGMPIR(1)=DGMPI
  1. . S DPTX=$G(DGFLDS(.01)) D ASKADD^DPTLK2 I DPTDFN'>0 S DGDFN=0 Q
  1. . S DGDFN=$$ADD(.DGFLDS,.DG20NAME) Q:'DGDFN
  1. . S DGMPIR(+$O(DGMPIR(0)),"DFN")=DGDFN
  1. . S DGMPIR("AddType")=$S(DGKEYREQ:"Explicit",1:"Implicit")
  1. . S DGMPIR("mcid")=DGMCID
  1. .;**981 - Story 841885 (ckn)
  1. . S DGMPIR("SelIdentifier")=""
  1. . D MPIADD(.DGMPIR)
  1. ;
  1. QUIT Q $S(DGDFN:DGDFN,1:0)
  1. ;
  1. MPIADD(DGMPIR) ; - call to add patient to the MPI and store ICN locally
  1. ; - web service call for adding and getting new ICN
  1. ;**1024,Story 1258907 (mko): Add a flag to indicate a new ICN needs to be added.
  1. N DGNEWICN
  1. I '$G(DGMPIR(+$O(DGMPIR(0)),"ICN")) D
  1. . S DGNEWICN=1
  1. . W !,"Adding patient to the MVI..."
  1. . N DGMPIICN
  1. . I '$D(DGMPIR("AddType")) S DGMPIR("AddType")="Implicit"
  1. . D GETICN^MPIFXMLI(.DGMPIICN,.DGMPIR)
  1. . I $G(DGMPIICN("ICN"))>0 S DGMPIR(+$O(DGMPIR(0)),"ICN")=DGMPIICN("ICN")
  1. . E D Q
  1. .. W !,"Unable to add to MVI!",!,$G(DGMPIICN("ERRTXT")),!
  1. .. S ^XTMP("MPIF EXPLICIT QUEUE",0)=$$FMADD^XLFDT(DT,60)_"^"_DT_"^MPIF EXPLICIT QUEUE"
  1. .. S ^XTMP("MPIF EXPLICIT QUEUE",DGDFN)=DT_"^"_DGMPIR("AddType")_"^"_$G(DGMPIR(+$O(DGMPIR(0)),"mcid"))_"^"_$G(DGMPIICN("ERRTXT"))
  1. .. S X=$$ICNLC^MPIF001(DGDFN)
  1. ;
  1. ; - need to have MPI do MPI fields
  1. S ^XTMP("DPTLK7 A24 IN-PROCESS",0)=$$FMADD^XLFDT(DT,10)_"^"_DT_"^TRACK PROCESSING OF A24 MESSAGES"
  1. S ^XTMP("DPTLK7 A24 IN-PROCESS",DGDFN)=DT
  1. I $G(DGMPIR(+$O(DGMPIR(0)),"ICN")) D VIC40^MPIFAPI(DGDFN,DGMPIR(+$O(DGMPIR(0)),"ICN"))
  1. ;
  1. ;**1024,Story 1258907 (mko): Add the TFs returned from the Enterprise Search in case MFN-MF0 hasn't been received and processed by this point
  1. D:'$G(DGNEWICN)
  1. . N DGTFARR
  1. . M DGTFARR=DGMPIR(+$O(DGMPIR(0)),"IDS")
  1. . D ADDTF^DPTLK7A(DGDFN,.DGTFARR)
  1. Q
  1. ;
  1. NAME(DGX,DG20NAME,DGOUT) ;- ask for name components
  1. N DGC,DGCL,DGCOM,DGCX,DGI,DGY,DIR,X,DGCOMP
  1. START S DGOUT=0
  1. S DGCOM="FAMILY^GIVEN^MIDDLE^PREFIX^SUFFIX^DEGREE"
  1. S DGCX=" (LAST) NAME^ (FIRST) NAME^ NAME"
  1. S DGCL="1:35^1:25^1:25^1:10^1:10^1:10"
  1. I $G(DGX)'?9N S DGX=$G(DGX) D STDNAME^XLFNAME(.DGX,"C")
  1. S DGX("SUFFIX")=$$CLEANC^XLFNAME(DGX("SUFFIX"))
  1. M DG20NAME=DGX
  1. S DIR("PRE")="D:X'=""@"" NCEVAL^DPTNAME1(DGCOMP,.X)"
  1. W !,"Patient name components--"
  1. ;DG*5.3*1111 removed PREFIX (#4) and DEGREE (#6) of the NAME COMPONENTS (#20) file
  1. ;F DGI=1:1:6 S DGC($P(DGCOM,U,DGI),DGI)=""
  1. F DGI=1:1:3,5 S DGC($P(DGCOM,U,DGI),DGI)=""
  1. ;DG*5.3*1111 removed PREFIX (#4) and DEGREE (#6) of the NAME COMPONENTS (#20) file
  1. ;F DGI=1:1:6 Q:DGOUT D
  1. F DGI=1:1:3,5 Q:DGOUT D
  1. AGAIN .S DGCOMP=$P(DGCOM,U,DGI)
  1. . S DIR("A")=DGCOMP_$P(DGCX,U,DGI)
  1. . S DIR(0)=$S(DGI=1:"F^"_$P(DGCL,U,DGI),1:"FO^"_$P(DGCL,U,DGI))
  1. . S DIR("PRE")="D NCEVAL^DPTNAME1(DGCOMP,.X)"
  1. . S DIR("B")=$S($D(DG20NAME(DGCOMP)):DG20NAME(DGCOMP),1:$G(DGX(DGCOMP)))
  1. . K:'$L(DIR("B")) DIR("B")
  1. ASK . D ^DIR I $D(DTOUT)!(X=U) S DGOUT=1 Q
  1. . I $A(X)=94 D JUMP^DPTNAME1(.DGI) G AGAIN
  1. . I X="@",DGI=1 W !,$C(7),"Family name cannot be deleted!" G ASK
  1. . I X="@" S DG20NAME(DGCOMP)="" Q
  1. . Q:'$L(X)
  1. . S DG20NAME=X
  1. . I DGCOMP="SUFFIX" S DG20NAME=$$CLEANC^XLFNAME(DG20NAME)
  1. . S DG20NAME=$$FORMAT^XLFNAME7(DG20NAME,1,35,,3,,1,1)
  1. . I '$L(DG20NAME) W " ??",$C(7) G ASK
  1. . W:DG20NAME'=X " (",DG20NAME,")" S DG20NAME(DGCOMP)=DG20NAME
  1. Q:DGOUT ""
  1. ; Reconstruct name
  1. S DG20NAME=$$NAMEFMT^XLFNAME(.DG20NAME,"F","CFL30")
  1. ; Format the .01 value
  1. M DGY=DG20NAME
  1. S DG20NAME=$$FORMAT^XLFNAME7(.DGY,3,30,,2)
  1. ; Check the length
  1. I $L(DG20NAME)<3 D G START
  1. . W !,"Invalid values to use, full name must be at least 3 characters!",$C(7)
  1. . K DG20NAME,DGX,DGCOMP
  1. Q
  1. ;
  1. ADDRESS(DGFLDS,DGOUT) ;- prompt for address
  1. N DGRET,FSTR
  1. ;.111 STREET ADDRESS [LINE 1] (both, free text)
  1. ;.112 STREET ADDRESS [LINE 2] (both, free text)
  1. ;.113 STREET ADDRESS [LINE 3] (both, free text)
  1. ;.114 CITY (both, free text)
  1. ;.115 STATE (external^internal)
  1. ;.116 ZIP CODE (both, free text)
  1. ;.117 COUNTY (external^internal^code)
  1. ;.1171 PROVINCE (both, free text)
  1. ;.1172 POSTAL CODE (both, free text)
  1. ;.1112 ZIP+4 (both, free text)
  1. ;.1173 COUNTRY (external^internal)
  1. ;.121 BAD ADDRESS INDICATOR (external^internal)
  1. W !,"Patient address--"
  1. D EN^DGREGAED(,,,.DGRET)
  1. ; address doesn't prompt for phone but returns it, don't want
  1. ; to overwrite
  1. K DGRET(.131)
  1. M DGFLDS=DGRET
  1. Q
  1. FLDS(DGFLDS,DGNAME,DGOUT) ;- prompt for the various FM fields
  1. ; Data returned in array
  1. ;DGFLDS(.09)=SSN*
  1. ;DGFLDS(.03)=DOB*
  1. ;DGFLDS(.02)=GENDER*
  1. ;DGFLDS(391)=TYPE (required)
  1. ;DGFLDS(1901)=VETERAN (Y/N)? (required)
  1. ;DGFLDS(.301)=SERVICE CONNECTED? (required)
  1. ;DGFLDS(.2403)=MMN
  1. ;DGFLDS(.092)=POB (city)
  1. ;DGFLDS(.093)=POB (state)
  1. ;DGFLDS(994)=MBI
  1. ;DGFLDS(.131)=PHONE
  1. ;DGFLDS("EDIPI")=EDIPI
  1. ;
  1. W !,"Patient identifiers--"
  1. ; SSN is special handling
  1. N DGFLD,DIR,X,Y,DG20NAME
  1. S DIR(0)="F^1:9^K:X'?9N&(X'=""P"")&(X'=""p"") X"
  1. S DIR("A")="SOCIAL SECURITY NUMBER"
  1. S:$D(DGFLDS(.09)) DIR("B")=DGFLDS(.09)
  1. S DIR("?")="Answer with the individual's social security, must be 9 numbers or 'P'."
  1. D ^DIR
  1. I $D(DUOUT) S DGOUT=1 Q
  1. S DGFLDS(.09)=X
  1. K DIR
  1. ; Story 338378 (elz) if pseudo, prompt pseudo reason
  1. I DGFLDS(.09)="P"!(DGFLDS(.09)="p") D PSREASON(.DGFLDS,.DGOUT) Q:DGOUT
  1. ; prompt for EDIPI value before the FM fields
  1. ;S DIR(0)="FO^10^K:X'?10N X"
  1. ;S DIR("A")="EDIPI"
  1. ;S DIR("?")="Answer with the individual's EDIPI, must be 10 numbers."
  1. ;D ^DIR
  1. ;I $D(DUOUT) S DGOUT=1 Q
  1. ;S DGFLDS("EDIPI")=X
  1. ;K DIR
  1. ;DG*5.3*1111 removed the PLACE OF BIRTH [CITY] (#.092) and PLACE OF BIRTH [STATE] (#.093) of PATIENT (#2) file
  1. ;F DGFLD=.03,.02,"ASKREQID",.2403,.092,.093,994,.131 D Q:$D(DTOUT)!($D(DUOUT))
  1. F DGFLD=.03,.02,"ASKREQID",.2403,994,.131 D Q:$D(DTOUT)!($D(DUOUT))
  1. . ;**1000,Story 1171329 (mko): Use ASKREQID as an indicator to prompt for three additional fields at this point
  1. . ;**1024,Story 1258907 (mko): Merge DPTIDS=DGFLDS. The input transform for VETERAN (Y/N)? looks at DOB response in DPTIDS(.03)
  1. . I DGFLD="ASKREQID" N DPTIDS M DPTIDS=DGFLDS D ASKREQID(.DGNAME,.DPTIDS) M:'$D(DUOUT) DGFLDS=DPTIDS Q
  1. . S DIR(0)="2,"_DGFLD_$S(DGFLD=.03:"",DGFLD=.02:"",1:"O")
  1. . D ^DIR
  1. . Q:$D(DIRUT)
  1. . S DGFLDS(DGFLD)=$P(Y,"^")
  1. S:$D(DTOUT)!($D(DUOUT)) DGOUT=1
  1. I $L($G(DGNAME)) S DGFLDS(.01)=DGNAME
  1. Q
  1. ;
  1. ASKREQID(DGNAME,DPTIDS) ;Use code from CHKID1^DPTLK2 to prompt for additional required identifiers
  1. ;**1000,Story 1171329 (mko): New subroutine
  1. ;Returns:
  1. ; DPTIDS(field#)=internal form of user response
  1. ; DUOUT=1 if ^, timeout, or other issue
  1. N DFN,DGVV,DIC,DO,DPT,DPTCT,DPTDFN,DPTGID,DPTID,DPTID0,DPTSET,DPTX,I,X,Y
  1. S DIC="^DPT(",DPTX=$G(DGNAME),DPTDFN=1 ;Variables needed by CHKID1^DPTLK2
  1. F DPTID=391,1901,.301 D Q:DPTDFN<0
  1. . I DPTID=.301,DPTIDS(1901)="N" S DPTIDS(.301)="N" Q
  1. . D CHKID1^DPTLK2
  1. S:DPTDFN<0 DUOUT=1
  1. Q
  1. ;
  1. PSREASON(DGFLDS,DGOUT) ; - prompts (and requires) pseudo reason
  1. N DIR,X,Y,DTOUT,DUOUT,DIROUT,DIRUT,DPTSET,P
  1. S DPTSET=$P(^DD(2,.0906,0),"^",3)
  1. PSAGAIN S DIR(0)="2,.0906" D ^DIR
  1. I $D(DTOUT)!($D(DUOUT))!($D(DIROUT)) S DGOUT=1 Q
  1. I Y="" W *7,"??",!!,"Choose from:" D
  1. . F P=1:1 Q:$P(DPTSET,";",P)="" W !,$P($P(DPTSET,";",P),":"),?10,$P($P(DPTSET,";",P),":",2)
  1. . W ! G PSAGAIN
  1. I Y["^" S DGOUT=1 Q
  1. S DGFLDS(.0906)=$P(Y,":")
  1. Q
  1. FORMAT(DGR,DGN,DGF) ; - format data for MPI call
  1. N X
  1. S:$G(DGN("FAMILY"))]"" DGR("Surname")=DGN("FAMILY")
  1. S:$G(DGN("GIVEN"))]"" DGR("FirstName")=DGN("GIVEN")
  1. S:$G(DGN("MIDDLE"))]"" DGR("MiddleName")=DGN("MIDDLE")
  1. S:$G(DGN("SUFFIX"))]"" DGR("Suffix")=DGN("SUFFIX")
  1. S:$G(DGN("PREFIX"))]"" DGR("Prefix")=DGN("PREFIX")
  1. S:$G(DGN("DEGREE"))]"" DGR("Degree")=DGN("DEGREE")
  1. S:$G(DGF(.02))]"" DGR("Gender")=DGF(.02)
  1. S:$G(DGF(.03))]"" DGR("DOB")=DGF(.03)
  1. I $G(DGF(.09))]"",DGF(.09)'="P",DGF(.09)'="p" S DGR("SSN")=DGF(.09)
  1. S:$G(DGF(.2403))]"" DGR("MMN")=DGF(.2403)
  1. S:$G(DGF(.092))]"" DGR("POBCity")=DGF(.092)
  1. S:$G(DGF(.093)) DGR("POBState")=$P($G(^DIC(5,DGF(.093),0)),"^",2)
  1. S:$G(DGF(994))]"" DGR("MBI")=DGF(994)
  1. S:$G(DGF(.131))]"" DGR("ResPhone")=DGF(.131)
  1. S:$D(DGF("EDIPI")) DGR("EDIPI")=DGF("EDIPI")
  1. ;
  1. ; only include address if deliverable
  1. I $G(DGF(.121))]"" D
  1. . S:$G(DGF(.111))]"" DGR("ResAddL1")=DGF(.111)
  1. . S:$G(DGF(.1112))]"" DGR("ResAddZip4")=DGF(.1112)
  1. . S:$G(DGF(.112))]"" DGR("ResAddL2")=DGF(.112)
  1. . S:$G(DGF(.113))]"" DGR("ResAddL3")=DGF(.113)
  1. . S:$G(DGF(.114))]"" DGR("CITY")=DGF(.114)
  1. . S:$P($G(DGF(.115)),"^",2) DGR("ResAddState")=$P($G(^DIC(5,$P(DGF(.115),"^",2),0)),"^",2)
  1. . S:$G(DGF(.1171))]"" DGR("ResAddProvince")=DGF(.1171)
  1. . S:$G(DGF(.1172))]"" DGR("ResAddPCode")=DGF(.1172)
  1. . S:$P($G(DGF(.1173)),"^")]"" DGR("ResAddCountry")=$P(DGF(.1173),"^")
  1. Q
  1. ;
  1. FORMATR(DGF,DGM,DG20NAME) ; - merge MPI and user input (MPI authorative)
  1. N DGX,DGY,DGZ
  1. S DGX=$O(DGM(0)) Q:'DGX
  1. S DG20NAME("FAMILY")=$G(DGM(DGX,"Surname"))
  1. S DG20NAME("GIVEN")=$G(DGM(DGX,"FirstName"))
  1. S DG20NAME("MIDDLE")=$G(DGM(DGX,"MiddleName"))
  1. S DG20NAME("PREFIX")=$G(DGM(DGX,"Prefix"))
  1. S DG20NAME("SUFFIX")=$G(DGM(DGX,"Suffix"))
  1. S DG20NAME("DEGREE")=$G(DGM(DGX,"Degree"))
  1. ;Reconstruct name
  1. S DG20NAME=$$NAMEFMT^XLFNAME(.DG20NAME,"F","CFL30")
  1. ;Format the .01 value
  1. M DGY=DG20NAME
  1. S DGF(.01)=$$FORMAT^XLFNAME7(.DGY,3,30,,2)
  1. S DGF(.02)=$G(DGM(DGX,"Gender"))
  1. S DGF(.03)=$G(DGM(DGX,"DOB"))
  1. S DGF(.09)=$G(DGM(DGX,"SSN"))
  1. S DGF(.2403)=$G(DGM(DGX,"MMN"))
  1. S DGF(.092)=$G(DGM(DGX,"POBCity"))
  1. S DGY=$S($G(DGM(DGX,"POBState"))]"":$O(^DIC(5,"C",DGM(DGX,"POBState"),0)),1:"")
  1. S DGF(.093)=DGY
  1. S:$G(DGM(DGX,"ResAddL1"))]"" DGF(.111)=DGM(DGX,"ResAddL1")
  1. S:$G(DGM(DGX,"ResAddL2"))]"" DGF(.112)=DGM(DGX,"ResAddL2")
  1. S:$G(DGM(DGX,"ResAddL3"))]"" DGF(.113)=DGM(DGX,"ResAddL3")
  1. S:$G(DGM(DGX,"City"))]"" DGF(.114)=DGM(DGX,"City")
  1. S:$G(DGM(DGX,"ResAddCity"))]"" DGF(.114)=DGM(DGX,"ResAddCity")
  1. ;
  1. S DGY=$S($G(DGM(DGX,"ResAddState"))]"":$O(^DIC(5,"C",DGM(DGX,"ResAddState"),0)),1:"")
  1. S:DGY DGF(.115)=DGY
  1. S DGY=$S($G(DGM(DGX,"Country"))]"":$O(^HL(779.004,"B",DGM(DGX,"Country"),0)),1:"")
  1. S:DGY DGF(.1173)=DGY
  1. S DGY=$S($G(DGM(DGX,"ResAddCountry"))]"":$O(^HL(779.004,"B",DGM(DGX,"ResAddCountry"),0)),1:"")
  1. S:DGY DGF(.1173)=DGY
  1. S:$G(DGM(DGX,"PCode"))]"" DGF(.1172)=DGM(DGX,"PCode")
  1. S:$G(DGM(DGX,"ResAddPCode"))]"" DGF(.1172)=DGM(DGX,"ResAddPCode")
  1. S:$G(DGM(DGX,"Province"))]"" DGF(.1171)=DGM(DGX,"Province")
  1. S:$G(DGM(DGX,"ResAddProvince"))]"" DGF(.1171)=DGM(DGX,"ResAddProvince")
  1. ;**967, Story 827326 (jfw) - Ensure Dash is removed if exists
  1. S:$G(DGM(DGX,"ResAddZip4"))]"" DGF(.1112)=$TR(DGM(DGX,"ResAddZip4"),"-","")
  1. S:$G(DGM(DGX,"ResPhone"))]"" DGF(.131)=DGM(DGX,"ResPhone")
  1. I $G(DGF(.1112)) D
  1. . N DGX,DGCNTY
  1. . D POSTAL^XIPUTIL(DGF(.1112),.DGX)
  1. . I $G(DGX("FIPS CODE"))]"",$G(DGX("STATE POINTER")) D
  1. .. S DGCNTY=$$FIND1^DIC(5.01,","_DGX("STATE POINTER")_",","MOXQ",$E($G(DGX("FIPS CODE")),3,5),"C")
  1. . I $D(DGCNTY) S DGF(.117)=DGCNTY
  1. ; alias loop
  1. S DGZ=0 F S DGZ=$O(DGM(DGX,"ALIAS",DGZ)) Q:'DGZ D
  1. . N DGY,DG20NAME
  1. . I $G(DGM(DGX,"ALIAS",DGZ,"Surname"))]"" D
  1. .. S DG20NAME("FAMILY")=$G(DGM(DGX,"ALIAS",DGZ,"Surname"))
  1. .. S DG20NAME("GIVEN")=$G(DGM(DGX,"ALIAS",DGZ,"FirstName"))
  1. .. S DG20NAME("MIDDLE")=$G(DGM(DGX,"ALIAS",DGZ,"MiddleName"))
  1. .. S DG20NAME("PREFIX")=$G(DGM(DGX,"ALIAS",DGZ,"Prefix"))
  1. .. S DG20NAME("SUFFIX")=$G(DGM(DGX,"ALIAS",DGZ,"Suffix"))
  1. .. S DG20NAME("DEGREE")=$G(DGM(DGX,"ALIAS",DGZ,"Degree"))
  1. .. ;Reconstruct name
  1. .. S DG20NAME=$$NAMEFMT^XLFNAME(.DG20NAME,"F","CFL30")
  1. .. ;Format the .01 value
  1. .. M DGY=DG20NAME
  1. .. S DGF("ALIAS",DGZ,.01)=$$FORMAT^XLFNAME7(.DGY,3,30,,2)
  1. . I $G(DGM(DGX,"ALIAS",DGZ,"SSN"))]"" S DGF("ALIAS",DGZ,1)=DGM(DGX,"ALIAS",DGZ,"SSN")
  1. S:$G(DGM(DGX,"ICN"))]"" DGF("ICN")=DGM(DGX,"ICN")
  1. ;
  1. ; - Story 338378 (elz) handle pseudo SSN
  1. I $G(DGF(.09))'?9N S DGF(.09)=$$PSEUDO($G(DGF(.01)),$G(DGF(.03)))
  1. E K DGF(.0906) ; remove pseudo reason if we have a ssn
  1. ;
  1. Q
  1. ADD(DGF,DG20NAME) ; - stuff in patient
  1. ; Pass in the fields to set in the DGF array.
  1. ; Alaso Name components in DG20NAME array. Returns new DFN
  1. N X,Y,SAVY,FDA,IEN,DATA,DO,DIC,DA,X,DLAYGO,REQ,VAFCNO,DGY,DPTX
  1. I $E($G(DGF(.09)),1,9)'?9N S DGF(.09)=$$PSEUDO(DGF(.01),$G(DGF(.03)))
  1. ; check for SSN already exist
  1. S DGY=$O(^DPT("SSN",DGF(.09),0)) I DGY>0,$D(^DPT(DGY,0)) W *7," SSN Already used by patient '",$P(^(0),"^"),"'." Q 0
  1. ;
  1. S DIC("DR")="",REQ="^.02^.03^.09^"
  1. S DGF=.01 F S DGF=$O(DGF(DGF)) Q:'DGF D
  1. . ; if the data has a second piece, then that's internal value to use
  1. . S DATA=$S($P(DGF(DGF),"^",2):$P(DGF(DGF),"^",2),1:DGF(DGF))
  1. . I DATA]""!(REQ[("^"_DGF_"^")) S DIC("DR")=DIC("DR")_DGF_$S(DATA]"":"////"_DATA,1:"")_";"
  1. ;**1000,Story 1171329 (mko): Don't default TYPE, VETERAN, or SERVICE CONNECTED
  1. ; These values were obtained earlier in the FLDS subroutine above
  1. ; patient type
  1. ;S DIC("DR")=DIC("DR")_"391///"_$O(^DG(391,"B","NSC VETERAN",0))_";"
  1. ; veteran
  1. ;S DIC("DR")=DIC("DR")_"1901///Y;"
  1. ; SC
  1. ;S DIC("DR")=DIC("DR")_".301///N;"
  1. ; date added
  1. S DIC("DR")=DIC("DR")_".097////"_DT
  1. ; who added
  1. S:$G(DUZ) DIC("DR")=DIC("DR")_";.096////"_DUZ
  1. ;
  1. S X=DGF(.01),DIC="^DPT(",DIC(0)="L",DLAYGO=2,VAFCNO=1
  1. D FILE^DICN
  1. S SAVY=+Y
  1. ;**1024
  1. S DGNEWP=$P(Y,U,3) ; TO ENSURE WE HAVE 3RD PIECE OF Y WHEN WE COME OUT OF ADD OF NEW PATIENT
  1. ;
  1. ; alias
  1. S X=0 F S X=$O(DGF("ALIAS",X)) Q:'X D
  1. . S DGF=0 F S DGF=$O(DGF("ALIAS",X,DGF)) Q:'DGF D
  1. .. S FDA(2.01,"+"_X_","_SAVY_",",.01)=DGF("ALIAS",X,.01)
  1. .. S:DGF("ALIAS",X,1)]"" FDA(2.01,"+"_X_","_SAVY_",",1)=DGF("ALIAS",X,1)
  1. ;
  1. I $D(FDA) D
  1. . N DG20NAME
  1. . D UPDATE^DIE("","FDA")
  1. ;
  1. ; send bulletin new patient added to system
  1. I SAVY>0 D BULL(SAVY)
  1. ;
  1. Q SAVY
  1. ;
  1. ADDREQ(DGFLDS) ; - determine if enough address data entered
  1. ; returns OK to proceed (1) or not (0)
  1. N DGOK,FIELD
  1. S DGOK=1
  1. ; is US or foreign
  1. I $$FOR^DGADDUTL($P(DGFLDS(.1173),"^")) D
  1. . F FIELD=.111,.114,.1171,.1172 S:$G(DGFLDS(FIELD))']"" DGOK=0
  1. E F FIELD=.111,.1112,.114,.115 S:$G(DGFLDS(FIELD))']"" DGOK=0
  1. I $L($G(DGFLDS(.131))) S DGOK=1
  1. Q DGOK
  1. ;
  1. PSEUDO(NAM,DOB) ; - return pseudo ssn
  1. N L1,L2,L3,Z
  1. S NAM=$G(DGF(.01)),DOB=$G(DGF(.03))
  1. I DOB="" S DOB=2000000
  1. S L1=$E($P(NAM," ",2),1),L3=$E(NAM,1),NAM=$P(NAM,",",2),L2=$E(NAM,1)
  1. S Z=L1 D CON^DGRPDD1 S L1=Z,Z=L2 D CON^DGRPDD1
  1. S L2=Z,Z=L3 D CON^DGRPDD1 S L3=Z
  1. Q L2_L1_L3_$E(DOB,4,7)_$E(DOB,2,3)_"P"
  1. ;
  1. BULL(SAVY) ; - send bulletin that new patient added
  1. N DGTEXT,DGNAM,DGSSN,DGDOB,DGB,DGZ
  1. S DGB=2
  1. S DGZ=$G(^DPT(SAVY,0))
  1. S DGNAM=$P(DGZ,"^"),DGSSN=$P(DGZ,"^",9),DGDOB=$P(DGZ,"^",3)
  1. S DGSSN=$E(DGSSN,1,3)_"-"_$E(DGSSN,4,5)_"-"_$E(DGSSN,6,10)
  1. S DGDOB=$$FMTE^XLFDT(DGDOB)
  1. S XMSUB="NEW PATIENT ADDED TO SYSTEM"
  1. S DGTEXT(1,0)="NAME: "_DGNAM
  1. S DGTEXT(2,0)="SSN : "_DGSSN
  1. S DGTEXT(3,0)="DOB : "_DGDOB
  1. D ^DGBUL
  1. Q