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

GMTSDEMC.m

Go to the documentation of this file.
  1. GMTSDEMC ;SLC/JLC - Sexual Orientation Data ;Jun 07, 2023@11:36
  1. ;;2.7;Health Summary;**141,144**;Oct 20, 1995;Build 17
  1. ;
  1. ;
  1. SEXOR ; Sexual Orientation
  1. N I,VAPTYP,VAHOW,VACOM,VADM,VA,VAERR,S1,TMP,GMTSNPG
  1. D DEM^VADPT
  1. D CKP^GMTSUP Q:$D(GMTSQIT)
  1. W "The sexual orientation information below shows all active entries listed by the",!
  1. D CKP^GMTSUP Q:$D(GMTSQIT)
  1. W "date they were updated.",!!
  1. W "------------------------------------------------------------------------------",!!
  1. I '$D(VADM(14,1)) G SEXORN
  1. F I=1:1:VADM(14,1) D
  1. . I $P(VADM(14,1,I,1),"^",2)'="A" Q
  1. . S TMP($P(VADM(14,1,I,3),"^"),I)=""
  1. I '$D(TMP) G SEXORN
  1. S S1=""
  1. F S S1=$O(TMP(S1)) Q:S1="" D
  1. . D CKP^GMTSUP Q:$D(GMTSQIT)
  1. . W S1,":",!
  1. . S I=0 F S I=$O(TMP(S1,I)) Q:'I D
  1. .. W ?5,$P(VADM(14,1,I),"^"),!
  1. .. I $P(VADM(14,1,I),U,2)="OTH" W ?8,$G(VADM(14,2)),!
  1. . W !
  1. Q
  1. SEXORN ;NO ACTIVE ENTRIES
  1. W "No active sexual orientation defined."
  1. Q
  1. PRONOUN ;Pronouns
  1. N VAPTYP,VAHOW,VACOM,VADM,VA,VAERR,GMTSFIRST,GMTSNUM,GMTSNPG,GMTSTEXT
  1. D DEM^VADPT
  1. D CKP^GMTSUP Q:$D(GMTSQIT)
  1. W !,"Pronoun(s): "
  1. I $D(VADM(14,3))>9 D
  1. .S GMTSFIRST=1,GMTSNUM=0 F S GMTSNUM=$O(VADM(14,3,GMTSNUM)) Q:'+GMTSNUM D
  1. ..I GMTSFIRST=1 S GMTSFIRST=0
  1. ..E D
  1. ...D CKP^GMTSUP Q:$D(GMTSQIT)
  1. ...W !
  1. ...I GMTSNPG W "Pronoun(s): "
  1. ..Q:$D(GMTSQIT)
  1. ..W ?10,$P($G(VADM(14,3,GMTSNUM)),U,1)
  1. .I $G(VADM(14,4))'="" D FORMAT^GMTSU(VADM(14,4),"Pronoun Open Text",1),LINE^GMTSU
  1. I $D(VADM(14,3))<10 W "<Not Provided>"
  1. D CKP^GMTSUP Q:$D(GMTSQIT)
  1. W !
  1. Q
  1. SIGI ;Self-Identified Gender
  1. N VAPTYP,VAHOW,VACOM,VADM,VA,VAERR,GMTSNPG,GMTSTEXT
  1. D DEM^VADPT
  1. D CKP^GMTSUP Q:$D(GMTSQIT)
  1. S GMTSTEXT=$P($G(VADM(14,5)),U,1)
  1. I GMTSTEXT="" S GMTSTEXT="<Not Provided>"
  1. W !,"Gender Identity: ",GMTSTEXT
  1. D CKP^GMTSUP Q:$D(GMTSQIT)
  1. W !
  1. Q