- 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 Jan 18, 2025@02:58:27 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