YTQAPI4 ;ASF/ALB MHQ REMOTE PROCEEDURES CHOICE/CHOICETYPE ; 4/3/07 1:44pm
;;5.01;MENTAL HEALTH;**85**;DEC 30,1994;Build 48
Q
IDENTAE(YSDATA,YS) ;choiceidentifier add/edit
;input:CT as Choicetype IEN
; ID a N,0 or 1
;Output: added or eddited
N DA,YSID
S YSCT=$G(YS("CT"))
I YSCT'?1N.N S YSDATA(1)="[ERROR]",YSDATA(2)="bad CT" Q ;-->out
I '$D(^YTT(601.751,"B",YSCT)) S YSDATA(1)="[ERROR]",YSDATA(2)=YSCT_"^not found" Q ;-->out
S YSID=$G(YS("ID"))
I (YSID'="1")&(YSID'="0")&(YSID'="N") S YSDATA(1)="[ERROR]",YSDATA(1)="bad id" Q ;--out
I $D(^YTT(601.89,"B",YSCT)) S DA=$O(^YTT(601.89,"B",YSCT,0)) S $P(^YTT(601.89,DA,0),U,2)=YSID,YSDATA(2)="eddited" Q ;good edit
L +^YTT(601.89):30
S DA=$$NEW^YTQLIB(601.89)
S ^YTT(601.89,DA,0)=YSCT_U_YSID
S DIK="^YTT(601.89,"
D IX1^DIK
L -^YTT(601.89)
S YSDATA(1)="[DATA]",YSDATA(2)=DA_"^added"
Q
TESTADD(YSDATA,YS) ;add new instrument
;input:CODE must be unique
;Output: new ien^added
N DA,YSCODE
S YSCODE=$G(YS("CODE"))
I ($L(YSCODE)>50)!($L(YSCODE)<3) S YSDATA(1)="[ERROR]",YSDATA(2)="bad ins name" Q ;-->out
I $D(^YTT(601.71,"B",YSCODE)) S DA=$O(^YTT(601.75,"B",YSCODE,0)),YSDATA(1)="[ERROR]",YSDATA(2)=DA_"^duplicate" Q ;-->out
L +^YTT(601.71):30
S DA=$$NEW^YTQLIB(601.71)
S ^YTT(601.71,DA,0)=YSCODE
S DIK="^YTT(601.71,"
D IX1^DIK
L -^YTT(601.71)
S YSDATA(1)="[DATA]",YSDATA(2)=DA_"^added"
Q
ADDCH(YSDATA,YS) ; check, report, force add a choice
N YSFORCE,YSTXT,YSIEN,DIK,DA,X,YSLEG
S YSFORCE=$G(YS("FORCE"),"N")
S YSTXT=$G(YS("TEXT"))
S YSLEG=$G(YS("LEGACY"))
I YSTXT="" S YSDATA(1)="[ERROR]",YSDATA(2)="no choice text" Q ;-->out
I $D(^YTT(601.75,"C",YSTXT)) S YSIEN=$O(^YTT(601.75,"C",YSTXT,0)) S YSDATA(1)="[DATA]",YSDATA(2)=YSIEN_"^existed",YSDATA(3)=YSTXT Q ;--> out
S X=YSTXT X ^DD("FUNC",13,1)
I (YSFORCE'?1"Y".E)&($D(^YTT(601.75,"AU",X))) S YSIEN=$O(^YTT(601.75,"AU",X,0)),YSDATA(1)="[DATA]",YSDATA(2)=YSIEN_"^question force",YSDATA(3)=^YTT(601.75,YSIEN,1) Q ;-->out
S DA=$$NEW^YTQLIB(601.75)
L +^YTT(601.75,DA):30
S ^YTT(601.75,DA,0)=DA,^YTT(601.75,DA,1)=YSTXT,$P(^YTT(601.75,DA,0),U,2)=YSLEG
S DIK="^YTT(601.75," D IX1^DIK
L -^YTT(601.75,DA)
S YSDATA(1)="[DATA]",YSDATA(2)=DA_"^added",YSDATA(3)=YSTXT
Q
CTADD(YSDATA,YS) ;add new choicetype
;input: list of choice iens in numbered sequence ex YS(1)=3,YS(2)=22
;output NEW choice type number
N YSI,YSERR,DA,YSFOUND,YSCTDA,YSCTX,I
S YSERR=0 F YSI=1:1 Q:'$D(YS(YSI)) S:'$D(^YTT(601.75,YS(YSI),0)) YSERR=YSI_";"_$G(YS(YSI))
I YSI=1 S YSDATA(1)="[ERROR]",YSDATA(2)="no choice list" Q ;-->out
I YSERR'=0 S YSDATA(1)="[ERROR]",YSDATA(2)="bad choice in list/"_YSERR Q ;-->out
S YSDATA(1)="[DATA]",YSFOUND=0
L +^YTT(601.751):30
S YSCT=$O(^YTT(601.751,"B",""),-1)
S YSCT=YSCT+1
F YSI=1:1 Q:'$D(YS(YSI)) D
. S DA=$$NEW^YTQLIB(601.751)
. S ^YTT(601.751,DA,0)=YSCT_U_YSI_U_YS(YSI)
. S DIK="^YTT(601.751,"
. D IX1^DIK
L -^YTT(601.751)
S YSDATA(2)=YSCT_"^added"
Q
CKEX ;check for existing choiceType
S YSCTDA=0
F Q:YSFOUND>0 S YSCTDA=$O(^YTT(601.751,"ACT",YS(1),YSCTDA)) Q:YSCTDA'>0 S YSCTX=$P(^YTT(601.751,YSCTDA,0),U) D
. S YSFOUND=0 F I=1:1 Q:'$D(YS(I)) S YSFOUND=$S($D(^YTT(601.751,"AC",YSCTX,I,YS(I))):YSFOUND+1,1:-999)
S:YSFOUND>1 YSFOUND=YSCTX
Q
CTDEL(YSDATA,YS) ;delete a choicetype
;Input: CHOICETYPE
;output: DELETED if sucessful
; LIST OF question iens if in use
N YSCT,DA,DIK,N
S YSCT=$G(YS("CHOICETYPE"),0)
I '$D(^YTT(601.751,"B",YSCT)) S YSDATA(1)="[ERROR]",YSDATA(2)="bad ct" Q ;-->out
I $D(^YTT(601.72,"ACT",YSCT)) D S YSDATA(1)="[ERROR]" Q ;--> out
. S N=1,YSQ=0 F S YSQ=$O(^YTT(601.72,"ACT",YSCT,YSQ)) Q:YSQ'>0 S N=N+1,YSDATA(N)=YSQ
S DA=0,DIK="^YTT(601.751,"
F S DA=$O(^YTT(601.751,"B",YSCT,DA)) Q:DA'>0 D ^DIK
S YSDATA(1)="[DATA]",YSDATA(2)=YSCT_" deleted"
Q
CHFIND(YSDATA,YS) ;find a choice in choicetypes
;input CHOICE AS ien of 601.75
;output: list of CHOCIETYPE iens
N YSCT,YSCH,N
S YSCH=$G(YS("CHOICE"),0)
I '$D(^YTT(601.75,YSCH,0)) S YSDATA(1)="[ERROR]",YSDATA(2)="bad choice IEN" Q ;-->out
S YSDATA(1)="[DATA]",YSDATA(2)="none found",YSCT=0,N=1
F S YSCT=$O(^YTT(601.751,"ACT",YSCH,YSCT)) Q:YSCT'>0 S N=N+1,YSDATA(N)=YSCT
Q
CTDESC(YSDATA,YS) ;describe choicetype
;input; CHOICETYPE
;output: CHOICETYPE^choicetype ien^sequence^choice ien^choice text
N YSCTN,YSCT,YSCH,N,YSQ,G
S YSCT=$G(YS("CHOICETYPE"),0)
I '$D(^YTT(601.751,"B",YSCT)) S YSDATA(1)="[ERROR]",YSDATA(2)="bad ct ien" Q ;-->out
S YSCTN=0,N=1,YSDATA(1)="[DATA]"
F S YSCTN=$O(^YTT(601.751,"B",YSCT,YSCTN)) Q:YSCTN'>0 D
. S G=$G(^YTT(601.751,YSCTN,0))
. S YSQ=$P(G,U,2),YSCH=$P(G,U,3)
. S N=N+1,YSDATA(N)=YSCT_U_YSCTN_U_YSQ_U_YSCH_U
. I YSCH?1N.N S YSDATA(N)=YSDATA(N)_$G(^YTT(601.75,YSCH,1))
Q
ORPHCT(YSDATA) ;find and delete orphan choiceTypes
;INPUT: none
;OUTPUT: list of choicetypes deleted
N N,YSCT,YSDA,DA
L ^YTT(601.751):30
S YSCT=0,N=1,DIK="^YTT(601.751,",YSDATA(1)="[DATA]",YSDATA(2)="none"
F S YSCT=$O(^YTT(601.751,"B",YSCT)) Q:YSCT'>0 I '$D(^YTT(601.72,"ACT",YSCT)) D
. S YSDA=0 F S YSDA=$O(^YTT(601.751,"B",YSCT,YSDA)) Q:YSDA'>0 S N=N+1,YSDATA(N)=YSCT_U_YSDA,DA=YSDA D ^DIK
L -^YTT(601.751)
Q
ORPHCH(YSDATA) ;find and delete orphan choices
;INPUT none
;OUTPUT list of choices deleted
N N,YSCH,YSDA,DA
L ^YTT(601.75):30
S YSCH=0,N=1,YSDATA="[DATA]",YSDATA(2)="none",DIK="^YTT(601.75,"
F S YSCH=$O(^YTT(601.75,YSCH)) Q:YSCH'>0 I '$D(^YTT(601.751,"ACT",YSCH)) D
. S N=N+1,YSDATA(N)=YSCH,DA=YSCH D ^DIK
L -^YTT(601.75)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQAPI4 5598 printed Sep 23, 2025@19:54:25 Page 2
YTQAPI4 ;ASF/ALB MHQ REMOTE PROCEEDURES CHOICE/CHOICETYPE ; 4/3/07 1:44pm
+1 ;;5.01;MENTAL HEALTH;**85**;DEC 30,1994;Build 48
+2 QUIT
IDENTAE(YSDATA,YS) ;choiceidentifier add/edit
+1 ;input:CT as Choicetype IEN
+2 ; ID a N,0 or 1
+3 ;Output: added or eddited
+4 NEW DA,YSID
+5 SET YSCT=$GET(YS("CT"))
+6 ;-->out
IF YSCT'?1N.N
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad CT"
QUIT
+7 ;-->out
IF '$DATA(^YTT(601.751,"B",YSCT))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)=YSCT_"^not found"
QUIT
+8 SET YSID=$GET(YS("ID"))
+9 ;--out
IF (YSID'="1")&(YSID'="0")&(YSID'="N")
SET YSDATA(1)="[ERROR]"
SET YSDATA(1)="bad id"
QUIT
+10 ;good edit
IF $DATA(^YTT(601.89,"B",YSCT))
SET DA=$ORDER(^YTT(601.89,"B",YSCT,0))
SET $PIECE(^YTT(601.89,DA,0),U,2)=YSID
SET YSDATA(2)="eddited"
QUIT
+11 LOCK +^YTT(601.89):30
+12 SET DA=$$NEW^YTQLIB(601.89)
+13 SET ^YTT(601.89,DA,0)=YSCT_U_YSID
+14 SET DIK="^YTT(601.89,"
+15 DO IX1^DIK
+16 LOCK -^YTT(601.89)
+17 SET YSDATA(1)="[DATA]"
SET YSDATA(2)=DA_"^added"
+18 QUIT
TESTADD(YSDATA,YS) ;add new instrument
+1 ;input:CODE must be unique
+2 ;Output: new ien^added
+3 NEW DA,YSCODE
+4 SET YSCODE=$GET(YS("CODE"))
+5 ;-->out
IF ($LENGTH(YSCODE)>50)!($LENGTH(YSCODE)<3)
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad ins name"
QUIT
+6 ;-->out
IF $DATA(^YTT(601.71,"B",YSCODE))
SET DA=$ORDER(^YTT(601.75,"B",YSCODE,0))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)=DA_"^duplicate"
QUIT
+7 LOCK +^YTT(601.71):30
+8 SET DA=$$NEW^YTQLIB(601.71)
+9 SET ^YTT(601.71,DA,0)=YSCODE
+10 SET DIK="^YTT(601.71,"
+11 DO IX1^DIK
+12 LOCK -^YTT(601.71)
+13 SET YSDATA(1)="[DATA]"
SET YSDATA(2)=DA_"^added"
+14 QUIT
ADDCH(YSDATA,YS) ; check, report, force add a choice
+1 NEW YSFORCE,YSTXT,YSIEN,DIK,DA,X,YSLEG
+2 SET YSFORCE=$GET(YS("FORCE"),"N")
+3 SET YSTXT=$GET(YS("TEXT"))
+4 SET YSLEG=$GET(YS("LEGACY"))
+5 ;-->out
IF YSTXT=""
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="no choice text"
QUIT
+6 ;--> out
IF $DATA(^YTT(601.75,"C",YSTXT))
SET YSIEN=$ORDER(^YTT(601.75,"C",YSTXT,0))
SET YSDATA(1)="[DATA]"
SET YSDATA(2)=YSIEN_"^existed"
SET YSDATA(3)=YSTXT
QUIT
+7 SET X=YSTXT
XECUTE ^DD("FUNC",13,1)
+8 ;-->out
IF (YSFORCE'?1"Y".E)&($DATA(^YTT(601.75,"AU",X)))
SET YSIEN=$ORDER(^YTT(601.75,"AU",X,0))
SET YSDATA(1)="[DATA]"
SET YSDATA(2)=YSIEN_"^question force"
SET YSDATA(3)=^YTT(601.75,YSIEN,1)
QUIT
+9 SET DA=$$NEW^YTQLIB(601.75)
+10 LOCK +^YTT(601.75,DA):30
+11 SET ^YTT(601.75,DA,0)=DA
SET ^YTT(601.75,DA,1)=YSTXT
SET $PIECE(^YTT(601.75,DA,0),U,2)=YSLEG
+12 SET DIK="^YTT(601.75,"
DO IX1^DIK
+13 LOCK -^YTT(601.75,DA)
+14 SET YSDATA(1)="[DATA]"
SET YSDATA(2)=DA_"^added"
SET YSDATA(3)=YSTXT
+15 QUIT
CTADD(YSDATA,YS) ;add new choicetype
+1 ;input: list of choice iens in numbered sequence ex YS(1)=3,YS(2)=22
+2 ;output NEW choice type number
+3 NEW YSI,YSERR,DA,YSFOUND,YSCTDA,YSCTX,I
+4 SET YSERR=0
FOR YSI=1:1
if '$DATA(YS(YSI))
QUIT
if '$DATA(^YTT(601.75,YS(YSI),0))
SET YSERR=YSI_";"_$GET(YS(YSI))
+5 ;-->out
IF YSI=1
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="no choice list"
QUIT
+6 ;-->out
IF YSERR'=0
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad choice in list/"_YSERR
QUIT
+7 SET YSDATA(1)="[DATA]"
SET YSFOUND=0
+8 LOCK +^YTT(601.751):30
+9 SET YSCT=$ORDER(^YTT(601.751,"B",""),-1)
+10 SET YSCT=YSCT+1
+11 FOR YSI=1:1
if '$DATA(YS(YSI))
QUIT
Begin DoDot:1
+12 SET DA=$$NEW^YTQLIB(601.751)
+13 SET ^YTT(601.751,DA,0)=YSCT_U_YSI_U_YS(YSI)
+14 SET DIK="^YTT(601.751,"
+15 DO IX1^DIK
End DoDot:1
+16 LOCK -^YTT(601.751)
+17 SET YSDATA(2)=YSCT_"^added"
+18 QUIT
CKEX ;check for existing choiceType
+1 SET YSCTDA=0
+2 FOR
if YSFOUND>0
QUIT
SET YSCTDA=$ORDER(^YTT(601.751,"ACT",YS(1),YSCTDA))
if YSCTDA'>0
QUIT
SET YSCTX=$PIECE(^YTT(601.751,YSCTDA,0),U)
Begin DoDot:1
+3 SET YSFOUND=0
FOR I=1:1
if '$DATA(YS(I))
QUIT
SET YSFOUND=$SELECT($DATA(^YTT(601.751,"AC",YSCTX,I,YS(I))):YSFOUND+1,1:-999)
End DoDot:1
+4 if YSFOUND>1
SET YSFOUND=YSCTX
+5 QUIT
CTDEL(YSDATA,YS) ;delete a choicetype
+1 ;Input: CHOICETYPE
+2 ;output: DELETED if sucessful
+3 ; LIST OF question iens if in use
+4 NEW YSCT,DA,DIK,N
+5 SET YSCT=$GET(YS("CHOICETYPE"),0)
+6 ;-->out
IF '$DATA(^YTT(601.751,"B",YSCT))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad ct"
QUIT
+7 ;--> out
IF $DATA(^YTT(601.72,"ACT",YSCT))
Begin DoDot:1
+8 SET N=1
SET YSQ=0
FOR
SET YSQ=$ORDER(^YTT(601.72,"ACT",YSCT,YSQ))
if YSQ'>0
QUIT
SET N=N+1
SET YSDATA(N)=YSQ
End DoDot:1
SET YSDATA(1)="[ERROR]"
QUIT
+9 SET DA=0
SET DIK="^YTT(601.751,"
+10 FOR
SET DA=$ORDER(^YTT(601.751,"B",YSCT,DA))
if DA'>0
QUIT
DO ^DIK
+11 SET YSDATA(1)="[DATA]"
SET YSDATA(2)=YSCT_" deleted"
+12 QUIT
CHFIND(YSDATA,YS) ;find a choice in choicetypes
+1 ;input CHOICE AS ien of 601.75
+2 ;output: list of CHOCIETYPE iens
+3 NEW YSCT,YSCH,N
+4 SET YSCH=$GET(YS("CHOICE"),0)
+5 ;-->out
IF '$DATA(^YTT(601.75,YSCH,0))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad choice IEN"
QUIT
+6 SET YSDATA(1)="[DATA]"
SET YSDATA(2)="none found"
SET YSCT=0
SET N=1
+7 FOR
SET YSCT=$ORDER(^YTT(601.751,"ACT",YSCH,YSCT))
if YSCT'>0
QUIT
SET N=N+1
SET YSDATA(N)=YSCT
+8 QUIT
CTDESC(YSDATA,YS) ;describe choicetype
+1 ;input; CHOICETYPE
+2 ;output: CHOICETYPE^choicetype ien^sequence^choice ien^choice text
+3 NEW YSCTN,YSCT,YSCH,N,YSQ,G
+4 SET YSCT=$GET(YS("CHOICETYPE"),0)
+5 ;-->out
IF '$DATA(^YTT(601.751,"B",YSCT))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad ct ien"
QUIT
+6 SET YSCTN=0
SET N=1
SET YSDATA(1)="[DATA]"
+7 FOR
SET YSCTN=$ORDER(^YTT(601.751,"B",YSCT,YSCTN))
if YSCTN'>0
QUIT
Begin DoDot:1
+8 SET G=$GET(^YTT(601.751,YSCTN,0))
+9 SET YSQ=$PIECE(G,U,2)
SET YSCH=$PIECE(G,U,3)
+10 SET N=N+1
SET YSDATA(N)=YSCT_U_YSCTN_U_YSQ_U_YSCH_U
+11 IF YSCH?1N.N
SET YSDATA(N)=YSDATA(N)_$GET(^YTT(601.75,YSCH,1))
End DoDot:1
+12 QUIT
ORPHCT(YSDATA) ;find and delete orphan choiceTypes
+1 ;INPUT: none
+2 ;OUTPUT: list of choicetypes deleted
+3 NEW N,YSCT,YSDA,DA
+4 LOCK ^YTT(601.751):30
+5 SET YSCT=0
SET N=1
SET DIK="^YTT(601.751,"
SET YSDATA(1)="[DATA]"
SET YSDATA(2)="none"
+6 FOR
SET YSCT=$ORDER(^YTT(601.751,"B",YSCT))
if YSCT'>0
QUIT
IF '$DATA(^YTT(601.72,"ACT",YSCT))
Begin DoDot:1
+7 SET YSDA=0
FOR
SET YSDA=$ORDER(^YTT(601.751,"B",YSCT,YSDA))
if YSDA'>0
QUIT
SET N=N+1
SET YSDATA(N)=YSCT_U_YSDA
SET DA=YSDA
DO ^DIK
End DoDot:1
+8 LOCK -^YTT(601.751)
+9 QUIT
ORPHCH(YSDATA) ;find and delete orphan choices
+1 ;INPUT none
+2 ;OUTPUT list of choices deleted
+3 NEW N,YSCH,YSDA,DA
+4 LOCK ^YTT(601.75):30
+5 SET YSCH=0
SET N=1
SET YSDATA="[DATA]"
SET YSDATA(2)="none"
SET DIK="^YTT(601.75,"
+6 FOR
SET YSCH=$ORDER(^YTT(601.75,YSCH))
if YSCH'>0
QUIT
IF '$DATA(^YTT(601.751,"ACT",YSCH))
Begin DoDot:1
+7 SET N=N+1
SET YSDATA(N)=YSCH
SET DA=YSCH
DO ^DIK
End DoDot:1
+8 LOCK -^YTT(601.75)
+9 QUIT
