GMTSDEM2 ; SLC/DLT,KER - Demographics (cont) ; 12/11/2002 [9/16/03 7:29am]
;;2.7;Health Summary;**56,58,60,62**;Oct 20, 1995
;
; External References
; DBIA 10061 OAD^VADPT
; DBIA 10061 DEM^VADPT
; DBIA 951 ^IBE(355.1
; DBIA 794 ^DIC(36
; DBIA 2056 $$GET1^DIQ (file #36, and #355.1)
; DBIA 10145 ALL^IBCNS1
; DBIA 10104 $$UP^XLFSTR
;
NOKC ; Next of Kin Component
N GMTSNOK S GMTSNOK="" D NOK Q
NOK ; Next of Kin
Q:$D(GMTSQIT) N %,%H,STR,STR1,STR2,NOKTYPE,ADR,VAERR,VAOA K VAOA("A") D OAD^VADPT
I $L($G(VAOA(9))) D
. ; Primary Next of Kin
. S NOKTYPE="Primary" D DNOK
. S VAOA("A")=3 D OAD^VADPT
. I $L($G(VAOA(9))) D
. . ; Secondary Next of Kin
. . K GMTSNOK S NOKTYPE="Secondary" D DNOK
Q
DNOK ; Display Next of Kin
D:'$D(GMTSNOK) WRT^GMTSDEM("",,,,0) Q:$D(GMTSQIT)
S STR1=$$UP^XLFSTR(VAOA(9)),STR2=$S('$L(VAOA(10)):"<not given>",1:$$UP^XLFSTR(VAOA(10)))
D WRT^GMTSDEM(($G(NOKTYPE)_" NOK"),STR1,"Relation",STR2,1) Q:$D(GMTSQIT)
S ADR=$G(VAOA(1)) K VAOA(1) I '$L(ADR) S ADR=$G(VAOA(2)) K VAOA(2) I '$L(ADR) S ADR=$G(VAOA(3)) K VAOA(3)
S STR=$S('$L(ADR):"<street address not available>",1:$$UP^XLFSTR(ADR))
K:STR="<street address not available>" VAOA(1),VAOA(2),VAOA(3)
D WRT^GMTSDEM("",STR,"Phone",VAOA(8),1) Q:$D(GMTSQIT)
S ADR=$G(VAOA(2)) K VAOA(2) I '$L(ADR) S ADR=$G(VAOA(3)) K VAOA(3)
S STR=$$UP^XLFSTR(ADR) D:$L(STR) WRT^GMTSDEM("",STR,,,1) Q:$D(GMTSQIT)
S ADR=$G(VAOA(3))
S STR=$$UP^XLFSTR(ADR) D:$L(STR) WRT^GMTSDEM("",STR,,,1) Q:$D(GMTSQIT)
I VAOA(4)'="" D
. S STR=$$UP^XLFSTR(VAOA(4)) S:VAOA(5) STR=STR_", "_$$UP^XLFSTR($P(VAOA(5),U,2)) S:VAOA(6) STR=STR_" "_$$UP^XLFSTR(VAOA(6))
. D WRT^GMTSDEM("",STR,,,1) Q:$D(GMTSQIT)
Q
;
INS ; Insurance Info
N I,INSURE,GMTSX,IEN,VAL,CLAIM,COMPANY,TYPE,COB,SUBSCRIB,GROUP,HOLDER,EFFECT,EXPIRE
D ALL^IBCNS1(DFN,"INSURE") Q:$O(INSURE(0))=""
S I=0 F S I=$O(INSURE(I)) Q:'I D Q:$D(GMTSQIT)
. S (COMPANY,TYPE,GROUP,HOLDER,EFFECT,EXPIRE)=""
. S GMTSX=INSURE(I,0),IEN=+GMTSX
. ; Insurance Company
. S COMPANY=$$GET1^DIQ(36,(+IEN_","),.01) Q:'$L(COMPANY)
. S CLAIM=INSURE(I,355.3)
. ; Policy Type
. S IEN=$P(CLAIM,"^",9)
. S TYPE="" I IEN]"" D
. . S TYPE=$$GET1^DIQ(355.1,(+IEN_","),.01) S TYPE=$$ABR(TYPE)
. ; Group Number
. S GROUP=$P(CLAIM,"^",4)
. S GMTSX=INSURE(I,0),VAL=$P(GMTSX,"^",6)
. ; Insurance Policy Holder
. S HOLDER=$S(VAL="v":"SELF",VAL="s":"SPOUSE",1:"OTHER")
. ; Insurance Effect Date
. S EFFECT=$P(GMTSX,"^",8)
. ; Insurance Expiration Date
. S EXPIRE=$P(GMTSX,"^",4)
. ; Subscriber ID
. S SUBSCRIB=$P($G(INSURE(I,0)),"^",2)
. ; Coordination of Benefits
. S COB=+($P($G(INSURE(I,0)),"^",20))
. S COB=$S(COB=1:"PRIMARY",COB=2:"SECONDARY",COB=3:"TERTIARY",1:"UNKNOWN")
. Q:$D(GMTSQIT) D WRT^GMTSDEM("",,,,0) Q:$D(GMTSQIT)
. D WRT^GMTSDEM("Insurance Company",$E(COMPANY,1,27),"Holder",HOLDER,1) Q:$D(GMTSQIT)
. I $L(TYPE)!($L(EFFECT)) D WRT^GMTSDEM("Policy Type",$E(TYPE,1,28),"Effective",$$EDT^GMTSU(EFFECT),1) Q:$D(GMTSQIT)
. I $L(GROUP)!($L(EXPIRE)) D WRT^GMTSDEM("Group #",$E(GROUP,1,28),"Expires",$$EDT^GMTSU(EXPIRE),1) Q:$D(GMTSQIT)
. I $L(SUBSCRIB)!($L(COB)) D WRT^GMTSDEM("Subscriber ID",$E(SUBSCRIB,1,28),"Coord. of Benefits",COB,1) Q:$D(GMTSQIT)
Q
;
RACE ; Race and Ethnicity
N GMTS D ER(+($G(DFN)),.GMTS) I $L($G(GMTS(2)))!($L($G(GMTS(6)))) D Q
. N GMTSD,GMTSI,GMTSC
. S (GMTSI,GMTSC)=0 F GMTSI=1:1 Q:'$L($P($G(GMTS(6)),"^",GMTSI)) D Q:$D(GMTSQIT)
. . S GMTSD=$P($G(GMTS(6)),"^",GMTSI),GMTSC=GMTSC+1
. . D:+GMTSC=1 WRT^GMTSDEM("Ethnicity",GMTSD,"",,1) Q:$D(GMTSQIT)
. . D:+GMTSC>1 WRT^GMTSDEM("",GMTSD,"",,1) Q:$D(GMTSQIT)
. Q:$D(GMTSQIT)
. S (GMTSI,GMTSC)=0 F GMTSI=1:1 Q:'$L($P($G(GMTS(2)),"^",GMTSI)) D Q:$D(GMTSQIT)
. . S GMTSD=$P($G(GMTS(2)),"^",GMTSI),GMTSC=GMTSC+1
. . D:+GMTSC=1 WRT^GMTSDEM("Race",GMTSD,"",,1) Q:$D(GMTSQIT)
. . D:+GMTSC>1 WRT^GMTSDEM("",GMTSD,"",,1) Q:$D(GMTSQIT)
I '$L($G(GMTS(2)))&('$L($G(GMTS(6)))) D Q
. N GMTSD,GMTSI,GMTSC S GMTSD=$G(GMTS(.06)) D WRT^GMTSDEM("Race",GMTSD,"",,1) Q:$D(GMTSQIT)
Q
RE ; Race and Ethnicity Component
N GMTS D ER(+($G(DFN)),.GMTS) I $L($G(GMTS(2)))!($L($G(GMTS(6)))) D Q
. N GMTSD,GMTSI,GMTSC
. S (GMTSI,GMTSC)=0 F GMTSI=1:1 Q:'$L($P($G(GMTS(6)),"^",GMTSI)) D Q:$D(GMTSQIT)
. . S GMTSD=$P($G(GMTS(6)),"^",GMTSI),GMTSC=GMTSC+1
. . D:+GMTSC=1 WRT^GMTSDEM("Ethnicity",GMTSD,"",,1) Q:$D(GMTSQIT)
. . D:+GMTSC>1 WRT^GMTSDEM("",GMTSD,"",,1) Q:$D(GMTSQIT)
. Q:$D(GMTSQIT)
. S (GMTSI,GMTSC)=0 F GMTSI=1:1 Q:'$L($P($G(GMTS(2)),"^",GMTSI)) D Q:$D(GMTSQIT)
. . S GMTSD=$P($G(GMTS(2)),"^",GMTSI),GMTSC=GMTSC+1
. . D:+GMTSC=1 WRT^GMTSDEM("Race",GMTSD,"",,1) Q:$D(GMTSQIT)
. . D:+GMTSC>1 WRT^GMTSDEM("",GMTSD,"",,1) Q:$D(GMTSQIT)
I '$L($G(GMTS(2)))&('$L($G(GMTS(6)))) D Q
. N GMTSD,GMTSI,GMTSC S GMTSD=$G(GMTS(.06)) D WRT^GMTSDEM("Race",GMTSD,"",,1) Q:$D(GMTSQIT)
Q
ER(DFN,GMTS) ; Get Ethnicity and Race
N VADM,VA,VAERR,GMTSD,GMTSI,GMTSC,X,Y S DFN=+($G(DFN)) Q:+DFN=0
D DEM^VADPT S GMTSD=$P($G(VADM(8)),"^",2),GMTS(.06)=GMTSD,GMTS("OLD")=GMTSD
S GMTSI=0 F S GMTSI=$O(VADM(11,GMTSI)) Q:+GMTSI=0 D
. S GMTSD=$P($G(VADM(11,GMTSI)),"^",2) S:$L(GMTSD) GMTS(6)=$G(GMTS(6))_"^"_GMTSD
S GMTSD=$G(GMTS(6)) F Q:$E(GMTSD,1)'="^" S GMTSD=$E(GMTSD,2,$L(GMTSD))
S GMTS(6)=GMTSD S GMTSI=0 F S GMTSI=$O(VADM(12,GMTSI)) Q:+GMTSI=0 D
. S GMTSD=$P($G(VADM(12,GMTSI)),"^",2) S:$L(GMTSD) GMTS(2)=$G(GMTS(2))_"^"_GMTSD
S GMTSD=$G(GMTS(2)) F Q:$E(GMTSD,1)'="^" S GMTSD=$E(GMTSD,2,$L(GMTSD))
S GMTS(2)=GMTSD,GMTSD=$G(GMTS(6))_"^^"_$G(GMTS(2)) F Q:$E(GMTSD,1)'="^" S GMTSD=$E(GMTSD,2,$L(GMTSD))
S GMTS("NEW")=GMTSD,GMTS(.06)=$G(GMTS(.06)),GMTS(2)=$G(GMTS(2)),GMTS(6)=$G(GMTS(6))
Q
;
ABR(X) ; Abbreviations
S X=$$UP^XLFSTR($G(X)) N TM,AB,SID S TM="PROCEDURES",AB="PROC" S:X[TM X=$$SW(X,TM,AB)
S TM="SUPPLEMENTAL",AB="SUP" S:X[TM X=$$SW(X,TM,AB) S TM="ORGANIZATION",AB="ORG" S:X[TM X=$$SW(X,TM,AB) S TM="ORIGIZ",AB="ORG" S:X[TM X=$$SW(X,TM,AB)
S TM="ORGANIZ",AB="ORG" S:X[TM X=$$SW(X,TM,AB) S TM="MAINTENANCE",AB="MAINT" S:X[TM X=$$SW(X,TM,AB) S TM="PROVIDER",AB="PROV" S:X[TM X=$$SW(X,TM,AB)
S TM="INDIVIDUAL",AB="INDIVID" S:X[TM X=$$SW(X,TM,AB) S TM="ASSOCATION",AB="ASSOC" S:X[TM X=$$SW(X,TM,AB) S TM="ASSOCIATION",AB="ASSOC" S:X[TM X=$$SW(X,TM,AB)
S TM="PRACT",AB="PRACT" S:X[TM X=$$SW(X,TM,AB) S TM="INSURANCE",AB="INS" S:X[TM X=$$SW(X,TM,AB) S TM="ETC.",AB="ETC" S:X[TM X=$$SW(X,TM,AB)
S TM="(ONLY)",AB="" S:X[TM X=$$SW(X,TM,AB) S TM="PROTECTION",AB="PROT" S:X[TM X=$$SW(X,TM,AB) S TM="PRACTICE",AB="PRACT" S:X[TM X=$$SW(X,TM,AB)
Q X
SW(X,Y,Z) ; Swap Abbreviation with Term
N TM,AB
S X=$G(X),TM=$$TRIM($G(Y)),AB=$$TRIM($G(Z)) Q:X="" "" Q:TM="" X Q:TM=AB X
F Q:X'[TM S X=$P(X,TM,1)_AB_$P(X,TM,2)
Q X
TRIM(X) ; Trim Spaces
S X=$G(X) Q:X="" X F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
F Q:X'[" " S X=$P(X," ",1)_" "_$P(X," ",2,229)
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSDEM2 7092 printed Sep 15, 2024@21:21:26 Page 2
GMTSDEM2 ; SLC/DLT,KER - Demographics (cont) ; 12/11/2002 [9/16/03 7:29am]
+1 ;;2.7;Health Summary;**56,58,60,62**;Oct 20, 1995
+2 ;
+3 ; External References
+4 ; DBIA 10061 OAD^VADPT
+5 ; DBIA 10061 DEM^VADPT
+6 ; DBIA 951 ^IBE(355.1
+7 ; DBIA 794 ^DIC(36
+8 ; DBIA 2056 $$GET1^DIQ (file #36, and #355.1)
+9 ; DBIA 10145 ALL^IBCNS1
+10 ; DBIA 10104 $$UP^XLFSTR
+11 ;
NOKC ; Next of Kin Component
+1 NEW GMTSNOK
SET GMTSNOK=""
DO NOK
QUIT
NOK ; Next of Kin
+1 if $DATA(GMTSQIT)
QUIT
NEW %,%H,STR,STR1,STR2,NOKTYPE,ADR,VAERR,VAOA
KILL VAOA("A")
DO OAD^VADPT
+2 IF $LENGTH($GET(VAOA(9)))
Begin DoDot:1
+3 ; Primary Next of Kin
+4 SET NOKTYPE="Primary"
DO DNOK
+5 SET VAOA("A")=3
DO OAD^VADPT
+6 IF $LENGTH($GET(VAOA(9)))
Begin DoDot:2
+7 ; Secondary Next of Kin
+8 KILL GMTSNOK
SET NOKTYPE="Secondary"
DO DNOK
End DoDot:2
End DoDot:1
+9 QUIT
DNOK ; Display Next of Kin
+1 if '$DATA(GMTSNOK)
DO WRT^GMTSDEM("",,,,0)
if $DATA(GMTSQIT)
QUIT
+2 SET STR1=$$UP^XLFSTR(VAOA(9))
SET STR2=$SELECT('$LENGTH(VAOA(10)):"<not given>",1:$$UP^XLFSTR(VAOA(10)))
+3 DO WRT^GMTSDEM(($GET(NOKTYPE)_" NOK"),STR1,"Relation",STR2,1)
if $DATA(GMTSQIT)
QUIT
+4 SET ADR=$GET(VAOA(1))
KILL VAOA(1)
IF '$LENGTH(ADR)
SET ADR=$GET(VAOA(2))
KILL VAOA(2)
IF '$LENGTH(ADR)
SET ADR=$GET(VAOA(3))
KILL VAOA(3)
+5 SET STR=$SELECT('$LENGTH(ADR):"<street address not available>",1:$$UP^XLFSTR(ADR))
+6 if STR="<street address not available>"
KILL VAOA(1),VAOA(2),VAOA(3)
+7 DO WRT^GMTSDEM("",STR,"Phone",VAOA(8),1)
if $DATA(GMTSQIT)
QUIT
+8 SET ADR=$GET(VAOA(2))
KILL VAOA(2)
IF '$LENGTH(ADR)
SET ADR=$GET(VAOA(3))
KILL VAOA(3)
+9 SET STR=$$UP^XLFSTR(ADR)
if $LENGTH(STR)
DO WRT^GMTSDEM("",STR,,,1)
if $DATA(GMTSQIT)
QUIT
+10 SET ADR=$GET(VAOA(3))
+11 SET STR=$$UP^XLFSTR(ADR)
if $LENGTH(STR)
DO WRT^GMTSDEM("",STR,,,1)
if $DATA(GMTSQIT)
QUIT
+12 IF VAOA(4)'=""
Begin DoDot:1
+13 SET STR=$$UP^XLFSTR(VAOA(4))
if VAOA(5)
SET STR=STR_", "_$$UP^XLFSTR($PIECE(VAOA(5),U,2))
if VAOA(6)
SET STR=STR_" "_$$UP^XLFSTR(VAOA(6))
+14 DO WRT^GMTSDEM("",STR,,,1)
if $DATA(GMTSQIT)
QUIT
End DoDot:1
+15 QUIT
+16 ;
INS ; Insurance Info
+1 NEW I,INSURE,GMTSX,IEN,VAL,CLAIM,COMPANY,TYPE,COB,SUBSCRIB,GROUP,HOLDER,EFFECT,EXPIRE
+2 DO ALL^IBCNS1(DFN,"INSURE")
if $ORDER(INSURE(0))=""
QUIT
+3 SET I=0
FOR
SET I=$ORDER(INSURE(I))
if 'I
QUIT
Begin DoDot:1
+4 SET (COMPANY,TYPE,GROUP,HOLDER,EFFECT,EXPIRE)=""
+5 SET GMTSX=INSURE(I,0)
SET IEN=+GMTSX
+6 ; Insurance Company
+7 SET COMPANY=$$GET1^DIQ(36,(+IEN_","),.01)
if '$LENGTH(COMPANY)
QUIT
+8 SET CLAIM=INSURE(I,355.3)
+9 ; Policy Type
+10 SET IEN=$PIECE(CLAIM,"^",9)
+11 SET TYPE=""
IF IEN]""
Begin DoDot:2
+12 SET TYPE=$$GET1^DIQ(355.1,(+IEN_","),.01)
SET TYPE=$$ABR(TYPE)
End DoDot:2
+13 ; Group Number
+14 SET GROUP=$PIECE(CLAIM,"^",4)
+15 SET GMTSX=INSURE(I,0)
SET VAL=$PIECE(GMTSX,"^",6)
+16 ; Insurance Policy Holder
+17 SET HOLDER=$SELECT(VAL="v":"SELF",VAL="s":"SPOUSE",1:"OTHER")
+18 ; Insurance Effect Date
+19 SET EFFECT=$PIECE(GMTSX,"^",8)
+20 ; Insurance Expiration Date
+21 SET EXPIRE=$PIECE(GMTSX,"^",4)
+22 ; Subscriber ID
+23 SET SUBSCRIB=$PIECE($GET(INSURE(I,0)),"^",2)
+24 ; Coordination of Benefits
+25 SET COB=+($PIECE($GET(INSURE(I,0)),"^",20))
+26 SET COB=$SELECT(COB=1:"PRIMARY",COB=2:"SECONDARY",COB=3:"TERTIARY",1:"UNKNOWN")
+27 if $DATA(GMTSQIT)
QUIT
DO WRT^GMTSDEM("",,,,0)
if $DATA(GMTSQIT)
QUIT
+28 DO WRT^GMTSDEM("Insurance Company",$EXTRACT(COMPANY,1,27),"Holder",HOLDER,1)
if $DATA(GMTSQIT)
QUIT
+29 IF $LENGTH(TYPE)!($LENGTH(EFFECT))
DO WRT^GMTSDEM("Policy Type",$EXTRACT(TYPE,1,28),"Effective",$$EDT^GMTSU(EFFECT),1)
if $DATA(GMTSQIT)
QUIT
+30 IF $LENGTH(GROUP)!($LENGTH(EXPIRE))
DO WRT^GMTSDEM("Group #",$EXTRACT(GROUP,1,28),"Expires",$$EDT^GMTSU(EXPIRE),1)
if $DATA(GMTSQIT)
QUIT
+31 IF $LENGTH(SUBSCRIB)!($LENGTH(COB))
DO WRT^GMTSDEM("Subscriber ID",$EXTRACT(SUBSCRIB,1,28),"Coord. of Benefits",COB,1)
if $DATA(GMTSQIT)
QUIT
End DoDot:1
if $DATA(GMTSQIT)
QUIT
+32 QUIT
+33 ;
RACE ; Race and Ethnicity
+1 NEW GMTS
DO ER(+($GET(DFN)),.GMTS)
IF $LENGTH($GET(GMTS(2)))!($LENGTH($GET(GMTS(6))))
Begin DoDot:1
+2 NEW GMTSD,GMTSI,GMTSC
+3 SET (GMTSI,GMTSC)=0
FOR GMTSI=1:1
if '$LENGTH($PIECE($GET(GMTS(6)),"^",GMTSI))
QUIT
Begin DoDot:2
+4 SET GMTSD=$PIECE($GET(GMTS(6)),"^",GMTSI)
SET GMTSC=GMTSC+1
+5 if +GMTSC=1
DO WRT^GMTSDEM("Ethnicity",GMTSD,"",,1)
if $DATA(GMTSQIT)
QUIT
+6 if +GMTSC>1
DO WRT^GMTSDEM("",GMTSD,"",,1)
if $DATA(GMTSQIT)
QUIT
End DoDot:2
if $DATA(GMTSQIT)
QUIT
+7 if $DATA(GMTSQIT)
QUIT
+8 SET (GMTSI,GMTSC)=0
FOR GMTSI=1:1
if '$LENGTH($PIECE($GET(GMTS(2)),"^",GMTSI))
QUIT
Begin DoDot:2
+9 SET GMTSD=$PIECE($GET(GMTS(2)),"^",GMTSI)
SET GMTSC=GMTSC+1
+10 if +GMTSC=1
DO WRT^GMTSDEM("Race",GMTSD,"",,1)
if $DATA(GMTSQIT)
QUIT
+11 if +GMTSC>1
DO WRT^GMTSDEM("",GMTSD,"",,1)
if $DATA(GMTSQIT)
QUIT
End DoDot:2
if $DATA(GMTSQIT)
QUIT
End DoDot:1
QUIT
+12 IF '$LENGTH($GET(GMTS(2)))&('$LENGTH($GET(GMTS(6))))
Begin DoDot:1
+13 NEW GMTSD,GMTSI,GMTSC
SET GMTSD=$GET(GMTS(.06))
DO WRT^GMTSDEM("Race",GMTSD,"",,1)
if $DATA(GMTSQIT)
QUIT
End DoDot:1
QUIT
+14 QUIT
RE ; Race and Ethnicity Component
+1 NEW GMTS
DO ER(+($GET(DFN)),.GMTS)
IF $LENGTH($GET(GMTS(2)))!($LENGTH($GET(GMTS(6))))
Begin DoDot:1
+2 NEW GMTSD,GMTSI,GMTSC
+3 SET (GMTSI,GMTSC)=0
FOR GMTSI=1:1
if '$LENGTH($PIECE($GET(GMTS(6)),"^",GMTSI))
QUIT
Begin DoDot:2
+4 SET GMTSD=$PIECE($GET(GMTS(6)),"^",GMTSI)
SET GMTSC=GMTSC+1
+5 if +GMTSC=1
DO WRT^GMTSDEM("Ethnicity",GMTSD,"",,1)
if $DATA(GMTSQIT)
QUIT
+6 if +GMTSC>1
DO WRT^GMTSDEM("",GMTSD,"",,1)
if $DATA(GMTSQIT)
QUIT
End DoDot:2
if $DATA(GMTSQIT)
QUIT
+7 if $DATA(GMTSQIT)
QUIT
+8 SET (GMTSI,GMTSC)=0
FOR GMTSI=1:1
if '$LENGTH($PIECE($GET(GMTS(2)),"^",GMTSI))
QUIT
Begin DoDot:2
+9 SET GMTSD=$PIECE($GET(GMTS(2)),"^",GMTSI)
SET GMTSC=GMTSC+1
+10 if +GMTSC=1
DO WRT^GMTSDEM("Race",GMTSD,"",,1)
if $DATA(GMTSQIT)
QUIT
+11 if +GMTSC>1
DO WRT^GMTSDEM("",GMTSD,"",,1)
if $DATA(GMTSQIT)
QUIT
End DoDot:2
if $DATA(GMTSQIT)
QUIT
End DoDot:1
QUIT
+12 IF '$LENGTH($GET(GMTS(2)))&('$LENGTH($GET(GMTS(6))))
Begin DoDot:1
+13 NEW GMTSD,GMTSI,GMTSC
SET GMTSD=$GET(GMTS(.06))
DO WRT^GMTSDEM("Race",GMTSD,"",,1)
if $DATA(GMTSQIT)
QUIT
End DoDot:1
QUIT
+14 QUIT
ER(DFN,GMTS) ; Get Ethnicity and Race
+1 NEW VADM,VA,VAERR,GMTSD,GMTSI,GMTSC,X,Y
SET DFN=+($GET(DFN))
if +DFN=0
QUIT
+2 DO DEM^VADPT
SET GMTSD=$PIECE($GET(VADM(8)),"^",2)
SET GMTS(.06)=GMTSD
SET GMTS("OLD")=GMTSD
+3 SET GMTSI=0
FOR
SET GMTSI=$ORDER(VADM(11,GMTSI))
if +GMTSI=0
QUIT
Begin DoDot:1
+4 SET GMTSD=$PIECE($GET(VADM(11,GMTSI)),"^",2)
if $LENGTH(GMTSD)
SET GMTS(6)=$GET(GMTS(6))_"^"_GMTSD
End DoDot:1
+5 SET GMTSD=$GET(GMTS(6))
FOR
if $EXTRACT(GMTSD,1)'="^"
QUIT
SET GMTSD=$EXTRACT(GMTSD,2,$LENGTH(GMTSD))
+6 SET GMTS(6)=GMTSD
SET GMTSI=0
FOR
SET GMTSI=$ORDER(VADM(12,GMTSI))
if +GMTSI=0
QUIT
Begin DoDot:1
+7 SET GMTSD=$PIECE($GET(VADM(12,GMTSI)),"^",2)
if $LENGTH(GMTSD)
SET GMTS(2)=$GET(GMTS(2))_"^"_GMTSD
End DoDot:1
+8 SET GMTSD=$GET(GMTS(2))
FOR
if $EXTRACT(GMTSD,1)'="^"
QUIT
SET GMTSD=$EXTRACT(GMTSD,2,$LENGTH(GMTSD))
+9 SET GMTS(2)=GMTSD
SET GMTSD=$GET(GMTS(6))_"^^"_$GET(GMTS(2))
FOR
if $EXTRACT(GMTSD,1)'="^"
QUIT
SET GMTSD=$EXTRACT(GMTSD,2,$LENGTH(GMTSD))
+10 SET GMTS("NEW")=GMTSD
SET GMTS(.06)=$GET(GMTS(.06))
SET GMTS(2)=$GET(GMTS(2))
SET GMTS(6)=$GET(GMTS(6))
+11 QUIT
+12 ;
ABR(X) ; Abbreviations
+1 SET X=$$UP^XLFSTR($GET(X))
NEW TM,AB,SID
SET TM="PROCEDURES"
SET AB="PROC"
if X[TM
SET X=$$SW(X,TM,AB)
+2 SET TM="SUPPLEMENTAL"
SET AB="SUP"
if X[TM
SET X=$$SW(X,TM,AB)
SET TM="ORGANIZATION"
SET AB="ORG"
if X[TM
SET X=$$SW(X,TM,AB)
SET TM="ORIGIZ"
SET AB="ORG"
if X[TM
SET X=$$SW(X,TM,AB)
+3 SET TM="ORGANIZ"
SET AB="ORG"
if X[TM
SET X=$$SW(X,TM,AB)
SET TM="MAINTENANCE"
SET AB="MAINT"
if X[TM
SET X=$$SW(X,TM,AB)
SET TM="PROVIDER"
SET AB="PROV"
if X[TM
SET X=$$SW(X,TM,AB)
+4 SET TM="INDIVIDUAL"
SET AB="INDIVID"
if X[TM
SET X=$$SW(X,TM,AB)
SET TM="ASSOCATION"
SET AB="ASSOC"
if X[TM
SET X=$$SW(X,TM,AB)
SET TM="ASSOCIATION"
SET AB="ASSOC"
if X[TM
SET X=$$SW(X,TM,AB)
+5 SET TM="PRACT"
SET AB="PRACT"
if X[TM
SET X=$$SW(X,TM,AB)
SET TM="INSURANCE"
SET AB="INS"
if X[TM
SET X=$$SW(X,TM,AB)
SET TM="ETC."
SET AB="ETC"
if X[TM
SET X=$$SW(X,TM,AB)
+6 SET TM="(ONLY)"
SET AB=""
if X[TM
SET X=$$SW(X,TM,AB)
SET TM="PROTECTION"
SET AB="PROT"
if X[TM
SET X=$$SW(X,TM,AB)
SET TM="PRACTICE"
SET AB="PRACT"
if X[TM
SET X=$$SW(X,TM,AB)
+7 QUIT X
SW(X,Y,Z) ; Swap Abbreviation with Term
+1 NEW TM,AB
+2 SET X=$GET(X)
SET TM=$$TRIM($GET(Y))
SET AB=$$TRIM($GET(Z))
if X=""
QUIT ""
if TM=""
QUIT X
if TM=AB
QUIT X
+3 FOR
if X'[TM
QUIT
SET X=$PIECE(X,TM,1)_AB_$PIECE(X,TM,2)
+4 QUIT X
TRIM(X) ; Trim Spaces
+1 SET X=$GET(X)
if X=""
QUIT X
FOR
if $EXTRACT(X,1)'=" "
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+2 FOR
if $EXTRACT(X,$LENGTH(X))'=" "
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+3 FOR
if X'[" "
QUIT
SET X=$PIECE(X," ",1)_" "_$PIECE(X," ",2,229)
+4 QUIT X
