- 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 Jan 18, 2025@03:19:26 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