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