- DGRRLU0 ;alb/GAH - DG Replacement and Rehosting RPC for VADPT ;10/10/05 09:53
- ;;5.3;Registration;**538,725,950**;Aug 13, 1993;Build 4
- ;
- SET X="You Can't Enter DGRRLU0 at top of routine!"
- QUIT
- ;
- BYFILTER(FILTER,FILTERV,BDATE,EDATE,SEARCH,VALUE,DELIM) ; -- search type by clinic, provider, or ward.
- NEW PCNT,OKAY,VAL
- K ^TMP("DGPTLKUP",$J)
- SET (OKAY,PCNT)=0
- ;
- DO ADD^DGRRUTL("<record count='0'>")
- SET LINENO=DGRRLINE
- FOR I=1:1 S VAL=$P(FILTERV,DELIM,I) QUIT:VAL="" DO Q:$$STOP^XOBVLIB()
- . IF FILTER="WARD" DO WARDPTS(VAL) S OKAY=1 Q
- . IF FILTER="CLINIC" DO CLINPTS(VAL,BDATE,EDATE) S OKAY=2 Q
- . IF FILTER="PROVIDER" D PROVPTS(VAL) S OKAY=3 Q
- . IF FILTER="SPECIALTY" D SPECPTS(VAL) S OKAY=4 Q
- ;
- IF OKAY<1 DO ADD^DGRRUTL("<error message='Filter not correctly specified'></error>")
- ;
- ; -- update the record count
- DO ADDPTS()
- SET @DGRRESLT@(LINENO)="<record count='"_PCNT_"'>"
- IF ($G(MAXSIZRE)<1) DO ADD^DGRRUTL("<maximum message=''></maximum>")
- DO ADD^DGRRUTL("<error message=''></error>")
- QUIT
- ;
- FILTCHK(DFN,TYPE,VALUE) ; -- Filter search -
- ; -- check patients to match search type and search value for filter searches
- ; -- returns 1 if matches, 0 if no match
- ;
- SET VALUE=$$UP^XLFSTR(VALUE)
- Q:($G(VALUE)="")!($G(VALUE)="*") 1
- Q:($G(TYPE)="") 1
- Q:($G(DFN)<1) 0
- ;
- NEW I,J,OKAY,CHKVAL
- SET OKAY=0
- IF TYPE="NAME" DO
- . IF VALUE[", " SET VALUE=$P(VALUE,", ")_","_$P(VALUE,", ",2) ; REMOVE FIRST SPACE line added sgg 070104
- . SET CHKVAL=$P($G(^DPT(DFN,0)),"^",1)
- . IF $E(CHKVAL,1,$LENGTH(VALUE))=VALUE SET OKAY=1
- IF TYPE="SSN" DO
- . SET CHKVAL=$P($G(^DPT(DFN,0)),"^",9)
- . SET VALUE=$TR(VALUE," -","") ; REMOVE DASHES AND SPACES line added sgg 070104
- . IF $E(CHKVAL,1,$LENGTH(VALUE))=VALUE SET OKAY=1
- IF TYPE="ICN" DO
- . ;SET CHKVAL=$P($G(^DPT(DFN,"MPI")),"^",1)
- . S CHKVAL=+$$GETICN^MPIF001(DFN)
- . IF $E(CHKVAL,1,$LENGTH(VALUE))=VALUE SET OKAY=1
- IF TYPE="SSN4" DO
- . SET CHKVAL=$E($P($G(^DPT(DFN,0)),"^",1),1)_$E($P($G(^DPT(DFN,0)),"^",9),6,9)
- . IF $E(CHKVAL,1,$LENGTH(VALUE))=VALUE SET OKAY=1
- QUIT OKAY
- ;
- WARDPTS(WARD) ; RETURN LIST OF PATIENTS IN A WARD
- ; Based on ORQPTQ2
- Q:+$G(WARD)<1
- N DFN
- S DFN=0
- S WARD=$P(^DIC(42,WARD,0),"^") ;GET WARD NAME FOR "CN" LOOKUP
- Q:WARD=""
- F D Q:DFN'>0 Q:$$STOP^XOBVLIB()
- . S DFN=$O(^DPT("CN",WARD,DFN)) Q:DFN'>0
- . Q:'$$FILTCHK(DFN,SEARCH,VALUE)
- . S ^TMP("DGPTLKUP",$J,$P($G(^DPT(DFN,0)),"^",1),DFN)=""
- Q
- ;
- PROVPTS(PROV) ; RETURN LIST OF PATIENTS LINKED TO A PRIMARY PROVIDER
- ; Based on ORQPTQ2
- ; "APR" xref is on field PROVIDER in file 2 (2;.104)
- ; "AAP" xref is on field ATTENDING PHYSICIAN in file 2 (2;.1041)
- ;
- Q:+$G(PROV)<1
- ;
- N DFN,XREF
- S DFN=0
- F XREF="AAP","APR" DO
- . F S DFN=$O(^DPT(XREF,PROV,DFN)) Q:DFN'>0 D Q:$$STOP^XOBVLIB()
- .. Q:'$$FILTCHK(DFN,SEARCH,VALUE)
- .. S ^TMP("DGPTLKUP",$J,$P($G(^DPT(DFN,0)),"^",1),DFN)=""
- Q
- ;
- CLINPTS(CLIN,BDATE,EDATE) ; RETURN LIST OF PTS W/CLINIC APPT W/IN BEGINNING AND END DATES
- Q:+$G(CLIN)<1
- ;
- N DFN,NAME,I,J,X,Y,ORJ,ORSRV,ORNOWDT,CHKX,CHKIN,MAXAPPTS,ORC,CLNAM,NOWDT
- S MAXAPPTS=200
- S NOWDT=$$NOW^XLFDT
- ;
- S DFN=0,I=1
- IF $G(BDATE)="" S BDATE="T"
- IF $G(EDATE)="" S EDATE="T+1"
- ;CONVERT BDATE AND EDATE INTO FILEMAN DATE/TIME
- D DT^DILF("T",BDATE,.BDATE,"","")
- D DT^DILF("T",EDATE,.EDATE,"","")
- I (BDATE=-1)!(EDATE=-1) S Y(1)="^Error in date range." Q
- S EDATE=$P(EDATE,".")_.5 ;ADD 1/2 DAY TO END DATE
- ;
- D CLINPT2(+CLIN,BDATE,EDATE)
- QUIT
- ;
- CLINPT2(CLIN,BEGIN,END) ; -- Use scheduling rehosting API from patches SD*5.3*253 and SD*5.3*275
- ; -- GETPLIST^SDAMA202(SDIEN,SDFIELDS,SDAPSTAT,SDSTART,SDEND,.SDRESULT,SDIOSTAT)
- ;
- K ^TMP($J,"SDAMA202","GETPLIST")
- NEW I,X,APPTS,APPTDT SET APPTS=""
- ;
- ; -- get appointment date/time, patient status, patient ien & name,
- ; only get appointment status = "R" for scheduled or kept appointments.
- DO GETPLIST^SDAMA202(+CLIN,"1;3;4","R",BEGIN,END,.APPTS)
- ;
- ; -- check number of appointments
- I APPTS<1 K ^TMP($J,"SDAMA202","GETPLIST") Q
- ;
- ; -- check for an error, may need to pass message up.
- I $D(^TMP($J,"SDAMA202","GETPTLIST","ERROR")) QUIT
- ;
- ; -- move list of appointments to list of patients, ordered by name, dfn
- S (I,X)=""
- F SET I=$O(^TMP($J,"SDAMA202","GETPLIST",I)) Q:I<1 S X=^(I,4) DO
- . Q:'$$FILTCHK(+X,SEARCH,VALUE) ;check if meets search criteria
- . S APPTDT=$G(^TMP($J,"SDAMA202","GETPLIST",I,1))
- . S ^TMP("DGPTLKUP",$J,$P(X,"^",2),+X,+APPTDT)=""
- K ^TMP($J,"SDAMA202","GETPLIST")
- QUIT
- ;
- SPECPTS(SPEC) ;Returns a list of patients associated with a specialty
- ; "ATR" cross reference is on the Treating Specialty (#.103) field
- ; in the Patient (#2) file and is a pointer to the Facility
- ; Treating Specialty (#45.7) file.
- ;
- Q:+$G(SPEC)<1
- N DFN
- S DFN=0
- F S DFN=$O(^DPT("ATR",+SPEC,DFN)) Q:DFN'>0 D Q:$$STOP^XOBVLIB()
- .Q:'$$FILTCHK(DFN,SEARCH,VALUE)
- .S ^TMP("DGPTLKUP",$J,$P($G(^DPT(DFN,0)),U),DFN)=""
- Q
- ;
- ADDPTS() ;
- N NAME,DFN,DGRRFLG,DGRRAPTS,DGRRCTR
- S NAME=""
- S (DGRRFLG,DGRRCTR)=0
- S DGRRAPTS=$S(FILTER="CLINIC":1,1:0)
- FOR SET NAME=$O(^TMP("DGPTLKUP",$J,NAME)) Q:NAME=""!(DGRRFLG=1) DO
- . S DFN="" FOR SET DFN=$O(^TMP("DGPTLKUP",$J,NAME,DFN)) Q:DFN<1!(DGRRFLG=1) DO
- .. S DGRRCTR=DGRRCTR+1
- .. I DGRRCTR>MAXSIZE S DGRRFLG=1 Q
- .. DO PTDATA^DGRRLUA(DFN,.PCNT)
- .. I FILTER'="CLINIC" Q
- .. D ADD^DGRRUTL("<appointments>")
- .. N APPTDT
- .. S APPTDT=""
- .. F S APPTDT=$O(^TMP("DGPTLKUP",$J,NAME,DFN,APPTDT)) Q:'APPTDT D
- ...D ADD^DGRRUTL("<appointmentTime>"_APPTDT_"</appointmentTime>")
- .. D ADD^DGRRUTL("</appointments>")
- .. D ADD^DGRRUTL("</patient>")
- I DGRRCTR>MAXSIZE D
- .IF $G(MAXSIZRE)<1 DO ADD^DGRRLU("<maximum message='Too many patients found (more than "_MAXSIZE_"). Please Limit Search.'></maximum>")
- .SET MAXSIZRE=1
- K ^TMP("DGPTLKUP",$J)
- ;IF ($G(MAXSIZRE)<1) DO ADD^DGRRUTL("<maximum message=''></maximum>")
- Q
- ;
- NAMECOMP(DFN,DGRRCNT) ; ENTRY IS +$P($G(^DPT(DFN,"NAME")),"^",1)
- ;
- N LN,FN,MI,PR,SU,DE,DGA,DGNMC
- S DGA=+$P($G(^DPT(DFN,"NAME")),U)_","
- D GETS^DIQ(20,+DGA,"1:6","","DGNMC")
- ;**950 STORY 625207 return name components as uppercase letters
- S LN=$$CHARCHK^DGRRUTL($G(DGNMC(20,DGA,1))),LN=$$UPPER^HLFNC(LN)
- S FN=$$CHARCHK^DGRRUTL($G(DGNMC(20,DGA,2))),FN=$$UPPER^HLFNC(FN)
- S MI=$$CHARCHK^DGRRUTL($G(DGNMC(20,DGA,3))),MI=$$UPPER^HLFNC(MI)
- S PR=$$CHARCHK^DGRRUTL($G(DGNMC(20,DGA,4))),PR=$$UPPER^HLFNC(PR)
- S SU=$$CHARCHK^DGRRUTL($G(DGNMC(20,DGA,5))),SU=$$UPPER^HLFNC(SU)
- S DE=$$CHARCHK^DGRRUTL($G(DGNMC(20,DGA,6))),DE=$$UPPER^HLFNC(DE)
- DO ADD^DGRRUTL("<namecomp number='"_DGRRCNT_"' last='"_LN_"' first='"_FN_"' middle='"_MI_"' prefix='"_PR_"' suffix='"_SU_"' degree='"_DE_"' ></namecomp>")
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRRLU0 6779 printed Feb 19, 2025@00:23:35 Page 2
- DGRRLU0 ;alb/GAH - DG Replacement and Rehosting RPC for VADPT ;10/10/05 09:53
- +1 ;;5.3;Registration;**538,725,950**;Aug 13, 1993;Build 4
- +2 ;
- +3 SET X="You Can't Enter DGRRLU0 at top of routine!"
- +4 QUIT
- +5 ;
- BYFILTER(FILTER,FILTERV,BDATE,EDATE,SEARCH,VALUE,DELIM) ; -- search type by clinic, provider, or ward.
- +1 NEW PCNT,OKAY,VAL
- +2 KILL ^TMP("DGPTLKUP",$JOB)
- +3 SET (OKAY,PCNT)=0
- +4 ;
- +5 DO ADD^DGRRUTL("<record count='0'>")
- +6 SET LINENO=DGRRLINE
- +7 FOR I=1:1
- SET VAL=$PIECE(FILTERV,DELIM,I)
- if VAL=""
- QUIT
- Begin DoDot:1
- +8 IF FILTER="WARD"
- DO WARDPTS(VAL)
- SET OKAY=1
- QUIT
- +9 IF FILTER="CLINIC"
- DO CLINPTS(VAL,BDATE,EDATE)
- SET OKAY=2
- QUIT
- +10 IF FILTER="PROVIDER"
- DO PROVPTS(VAL)
- SET OKAY=3
- QUIT
- +11 IF FILTER="SPECIALTY"
- DO SPECPTS(VAL)
- SET OKAY=4
- QUIT
- End DoDot:1
- if $$STOP^XOBVLIB()
- QUIT
- +12 ;
- +13 IF OKAY<1
- DO ADD^DGRRUTL("<error message='Filter not correctly specified'></error>")
- +14 ;
- +15 ; -- update the record count
- +16 DO ADDPTS()
- +17 SET @DGRRESLT@(LINENO)="<record count='"_PCNT_"'>"
- +18 IF ($GET(MAXSIZRE)<1)
- DO ADD^DGRRUTL("<maximum message=''></maximum>")
- +19 DO ADD^DGRRUTL("<error message=''></error>")
- +20 QUIT
- +21 ;
- FILTCHK(DFN,TYPE,VALUE) ; -- Filter search -
- +1 ; -- check patients to match search type and search value for filter searches
- +2 ; -- returns 1 if matches, 0 if no match
- +3 ;
- +4 SET VALUE=$$UP^XLFSTR(VALUE)
- +5 if ($GET(VALUE)="")!($GET(VALUE)="*")
- QUIT 1
- +6 if ($GET(TYPE)="")
- QUIT 1
- +7 if ($GET(DFN)<1)
- QUIT 0
- +8 ;
- +9 NEW I,J,OKAY,CHKVAL
- +10 SET OKAY=0
- +11 IF TYPE="NAME"
- Begin DoDot:1
- +12 ; REMOVE FIRST SPACE line added sgg 070104
- IF VALUE[", "
- SET VALUE=$PIECE(VALUE,", ")_","_$PIECE(VALUE,", ",2)
- +13 SET CHKVAL=$PIECE($GET(^DPT(DFN,0)),"^",1)
- +14 IF $EXTRACT(CHKVAL,1,$LENGTH(VALUE))=VALUE
- SET OKAY=1
- End DoDot:1
- +15 IF TYPE="SSN"
- Begin DoDot:1
- +16 SET CHKVAL=$PIECE($GET(^DPT(DFN,0)),"^",9)
- +17 ; REMOVE DASHES AND SPACES line added sgg 070104
- SET VALUE=$TRANSLATE(VALUE," -","")
- +18 IF $EXTRACT(CHKVAL,1,$LENGTH(VALUE))=VALUE
- SET OKAY=1
- End DoDot:1
- +19 IF TYPE="ICN"
- Begin DoDot:1
- +20 ;SET CHKVAL=$P($G(^DPT(DFN,"MPI")),"^",1)
- +21 SET CHKVAL=+$$GETICN^MPIF001(DFN)
- +22 IF $EXTRACT(CHKVAL,1,$LENGTH(VALUE))=VALUE
- SET OKAY=1
- End DoDot:1
- +23 IF TYPE="SSN4"
- Begin DoDot:1
- +24 SET CHKVAL=$EXTRACT($PIECE($GET(^DPT(DFN,0)),"^",1),1)_$EXTRACT($PIECE($GET(^DPT(DFN,0)),"^",9),6,9)
- +25 IF $EXTRACT(CHKVAL,1,$LENGTH(VALUE))=VALUE
- SET OKAY=1
- End DoDot:1
- +26 QUIT OKAY
- +27 ;
- WARDPTS(WARD) ; RETURN LIST OF PATIENTS IN A WARD
- +1 ; Based on ORQPTQ2
- +2 if +$GET(WARD)<1
- QUIT
- +3 NEW DFN
- +4 SET DFN=0
- +5 ;GET WARD NAME FOR "CN" LOOKUP
- SET WARD=$PIECE(^DIC(42,WARD,0),"^")
- +6 if WARD=""
- QUIT
- +7 FOR
- Begin DoDot:1
- +8 SET DFN=$ORDER(^DPT("CN",WARD,DFN))
- if DFN'>0
- QUIT
- +9 if '$$FILTCHK(DFN,SEARCH,VALUE)
- QUIT
- +10 SET ^TMP("DGPTLKUP",$JOB,$PIECE($GET(^DPT(DFN,0)),"^",1),DFN)=""
- End DoDot:1
- if DFN'>0
- QUIT
- if $$STOP^XOBVLIB()
- QUIT
- +11 QUIT
- +12 ;
- PROVPTS(PROV) ; RETURN LIST OF PATIENTS LINKED TO A PRIMARY PROVIDER
- +1 ; Based on ORQPTQ2
- +2 ; "APR" xref is on field PROVIDER in file 2 (2;.104)
- +3 ; "AAP" xref is on field ATTENDING PHYSICIAN in file 2 (2;.1041)
- +4 ;
- +5 if +$GET(PROV)<1
- QUIT
- +6 ;
- +7 NEW DFN,XREF
- +8 SET DFN=0
- +9 FOR XREF="AAP","APR"
- Begin DoDot:1
- +10 FOR
- SET DFN=$ORDER(^DPT(XREF,PROV,DFN))
- if DFN'>0
- QUIT
- Begin DoDot:2
- +11 if '$$FILTCHK(DFN,SEARCH,VALUE)
- QUIT
- +12 SET ^TMP("DGPTLKUP",$JOB,$PIECE($GET(^DPT(DFN,0)),"^",1),DFN)=""
- End DoDot:2
- if $$STOP^XOBVLIB()
- QUIT
- End DoDot:1
- +13 QUIT
- +14 ;
- CLINPTS(CLIN,BDATE,EDATE) ; RETURN LIST OF PTS W/CLINIC APPT W/IN BEGINNING AND END DATES
- +1 if +$GET(CLIN)<1
- QUIT
- +2 ;
- +3 NEW DFN,NAME,I,J,X,Y,ORJ,ORSRV,ORNOWDT,CHKX,CHKIN,MAXAPPTS,ORC,CLNAM,NOWDT
- +4 SET MAXAPPTS=200
- +5 SET NOWDT=$$NOW^XLFDT
- +6 ;
- +7 SET DFN=0
- SET I=1
- +8 IF $GET(BDATE)=""
- SET BDATE="T"
- +9 IF $GET(EDATE)=""
- SET EDATE="T+1"
- +10 ;CONVERT BDATE AND EDATE INTO FILEMAN DATE/TIME
- +11 DO DT^DILF("T",BDATE,.BDATE,"","")
- +12 DO DT^DILF("T",EDATE,.EDATE,"","")
- +13 IF (BDATE=-1)!(EDATE=-1)
- SET Y(1)="^Error in date range."
- QUIT
- +14 ;ADD 1/2 DAY TO END DATE
- SET EDATE=$PIECE(EDATE,".")_.5
- +15 ;
- +16 DO CLINPT2(+CLIN,BDATE,EDATE)
- +17 QUIT
- +18 ;
- CLINPT2(CLIN,BEGIN,END) ; -- Use scheduling rehosting API from patches SD*5.3*253 and SD*5.3*275
- +1 ; -- GETPLIST^SDAMA202(SDIEN,SDFIELDS,SDAPSTAT,SDSTART,SDEND,.SDRESULT,SDIOSTAT)
- +2 ;
- +3 KILL ^TMP($JOB,"SDAMA202","GETPLIST")
- +4 NEW I,X,APPTS,APPTDT
- SET APPTS=""
- +5 ;
- +6 ; -- get appointment date/time, patient status, patient ien & name,
- +7 ; only get appointment status = "R" for scheduled or kept appointments.
- +8 DO GETPLIST^SDAMA202(+CLIN,"1;3;4","R",BEGIN,END,.APPTS)
- +9 ;
- +10 ; -- check number of appointments
- +11 IF APPTS<1
- KILL ^TMP($JOB,"SDAMA202","GETPLIST")
- QUIT
- +12 ;
- +13 ; -- check for an error, may need to pass message up.
- +14 IF $DATA(^TMP($JOB,"SDAMA202","GETPTLIST","ERROR"))
- QUIT
- +15 ;
- +16 ; -- move list of appointments to list of patients, ordered by name, dfn
- +17 SET (I,X)=""
- +18 FOR
- SET I=$ORDER(^TMP($JOB,"SDAMA202","GETPLIST",I))
- if I<1
- QUIT
- SET X=^(I,4)
- Begin DoDot:1
- +19 ;check if meets search criteria
- if '$$FILTCHK(+X,SEARCH,VALUE)
- QUIT
- +20 SET APPTDT=$GET(^TMP($JOB,"SDAMA202","GETPLIST",I,1))
- +21 SET ^TMP("DGPTLKUP",$JOB,$PIECE(X,"^",2),+X,+APPTDT)=""
- End DoDot:1
- +22 KILL ^TMP($JOB,"SDAMA202","GETPLIST")
- +23 QUIT
- +24 ;
- SPECPTS(SPEC) ;Returns a list of patients associated with a specialty
- +1 ; "ATR" cross reference is on the Treating Specialty (#.103) field
- +2 ; in the Patient (#2) file and is a pointer to the Facility
- +3 ; Treating Specialty (#45.7) file.
- +4 ;
- +5 if +$GET(SPEC)<1
- QUIT
- +6 NEW DFN
- +7 SET DFN=0
- +8 FOR
- SET DFN=$ORDER(^DPT("ATR",+SPEC,DFN))
- if DFN'>0
- QUIT
- Begin DoDot:1
- +9 if '$$FILTCHK(DFN,SEARCH,VALUE)
- QUIT
- +10 SET ^TMP("DGPTLKUP",$JOB,$PIECE($GET(^DPT(DFN,0)),U),DFN)=""
- End DoDot:1
- if $$STOP^XOBVLIB()
- QUIT
- +11 QUIT
- +12 ;
- ADDPTS() ;
- +1 NEW NAME,DFN,DGRRFLG,DGRRAPTS,DGRRCTR
- +2 SET NAME=""
- +3 SET (DGRRFLG,DGRRCTR)=0
- +4 SET DGRRAPTS=$SELECT(FILTER="CLINIC":1,1:0)
- +5 FOR
- SET NAME=$ORDER(^TMP("DGPTLKUP",$JOB,NAME))
- if NAME=""!(DGRRFLG=1)
- QUIT
- Begin DoDot:1
- +6 SET DFN=""
- FOR
- SET DFN=$ORDER(^TMP("DGPTLKUP",$JOB,NAME,DFN))
- if DFN<1!(DGRRFLG=1)
- QUIT
- Begin DoDot:2
- +7 SET DGRRCTR=DGRRCTR+1
- +8 IF DGRRCTR>MAXSIZE
- SET DGRRFLG=1
- QUIT
- +9 DO PTDATA^DGRRLUA(DFN,.PCNT)
- +10 IF FILTER'="CLINIC"
- QUIT
- +11 DO ADD^DGRRUTL("<appointments>")
- +12 NEW APPTDT
- +13 SET APPTDT=""
- +14 FOR
- SET APPTDT=$ORDER(^TMP("DGPTLKUP",$JOB,NAME,DFN,APPTDT))
- if 'APPTDT
- QUIT
- Begin DoDot:3
- +15 DO ADD^DGRRUTL("<appointmentTime>"_APPTDT_"</appointmentTime>")
- End DoDot:3
- +16 DO ADD^DGRRUTL("</appointments>")
- +17 DO ADD^DGRRUTL("</patient>")
- End DoDot:2
- End DoDot:1
- +18 IF DGRRCTR>MAXSIZE
- Begin DoDot:1
- +19 IF $GET(MAXSIZRE)<1
- DO ADD^DGRRLU("<maximum message='Too many patients found (more than "_MAXSIZE_"). Please Limit Search.'></maximum>")
- +20 SET MAXSIZRE=1
- End DoDot:1
- +21 KILL ^TMP("DGPTLKUP",$JOB)
- +22 ;IF ($G(MAXSIZRE)<1) DO ADD^DGRRUTL("<maximum message=''></maximum>")
- +23 QUIT
- +24 ;
- NAMECOMP(DFN,DGRRCNT) ; ENTRY IS +$P($G(^DPT(DFN,"NAME")),"^",1)
- +1 ;
- +2 NEW LN,FN,MI,PR,SU,DE,DGA,DGNMC
- +3 SET DGA=+$PIECE($GET(^DPT(DFN,"NAME")),U)_","
- +4 DO GETS^DIQ(20,+DGA,"1:6","","DGNMC")
- +5 ;**950 STORY 625207 return name components as uppercase letters
- +6 SET LN=$$CHARCHK^DGRRUTL($GET(DGNMC(20,DGA,1)))
- SET LN=$$UPPER^HLFNC(LN)
- +7 SET FN=$$CHARCHK^DGRRUTL($GET(DGNMC(20,DGA,2)))
- SET FN=$$UPPER^HLFNC(FN)
- +8 SET MI=$$CHARCHK^DGRRUTL($GET(DGNMC(20,DGA,3)))
- SET MI=$$UPPER^HLFNC(MI)
- +9 SET PR=$$CHARCHK^DGRRUTL($GET(DGNMC(20,DGA,4)))
- SET PR=$$UPPER^HLFNC(PR)
- +10 SET SU=$$CHARCHK^DGRRUTL($GET(DGNMC(20,DGA,5)))
- SET SU=$$UPPER^HLFNC(SU)
- +11 SET DE=$$CHARCHK^DGRRUTL($GET(DGNMC(20,DGA,6)))
- SET DE=$$UPPER^HLFNC(DE)
- +12 DO ADD^DGRRUTL("<namecomp number='"_DGRRCNT_"' last='"_LN_"' first='"_FN_"' middle='"_MI_"' prefix='"_PR_"' suffix='"_SU_"' degree='"_DE_"' ></namecomp>")
- +13 ;