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

YTQAPI10.m

Go to the documentation of this file. 
  1. YTQAPI10 ;ASF/ALB MHQ COPY PROCEEDURES ;12/2/04 11:41am
  1.  ;;5.01;MENTAL HEALTH;**85**;Dec 30, 1994;Build 48
  1.  Q
  1. ZZ K YS,YSDATA R !,"OLD TEST: ",Z1:30 R !,"new test: ",Z2:30
  1.  S YS("ORIGINAL")=Z1,YS("NEW")=Z2 D COPY(.YSDATA,.YS)
  1.  Q
  1. COPY(YSDATA,YS) ;copy instrument
  1.  N %X,%Y,DA,DIK,G,G1,G2,N,N1,N3,X,Y,YSDISNEW,YSDISOLD,YSECNEW,YSERR
  1.  N YSFILE,YSI,YSISRNEW,YSKEYNEW,YSKEYOLD,YSKIPNEW,YSN,YSN1,YSNAT,YSNEWI,YSNEWNAM,YSNEWNUM,YSOLDI,YSOLDNAM
  1.  N YSOLDNUM,YSPROG,YSQUNEW,YSQX,YSRULNEW,YSRULOLD,YSSGNEW,YSSGOLD,YSSLNEW,YSSLOLD,Z1,Z2
  1.  S YSERR=0
  1.  K ^TMP($J,"YSM")
  1.  D PARSE Q:YSERR  ; set/check inputs
  1.  D INS ;add new test entry
  1.  D QUES ;duplicate questions
  1.  D INTRO ;introductions
  1.  D DISPLAY ; q<i>c displays
  1.  D SKIP ;skipped questions
  1.  D RULES^YTQAPI11 ;instrument rules and rules
  1.  D SECTION
  1.  D SCALES^YTQAPI11 ;scale grps,scales,keys
  1.  S YSDATA(1)="[DATA]"
  1.  Q
  1. SECTION ;headings
  1.  S YSFILE=601.81,N=0
  1.  S N=$O(^YTT(601.81,"AC",YSOLDNUM,N)) Q:N'>0  D
  1.  . S G1=^YTT(601.81,N,0)
  1.  . S YSECNEW=$$NEW^YTQLIB(YSFILE)
  1.  . S ^YTT(601.81,YSECNEW,0)=G1
  1.  . S $P(^YTT(601.81,YSECNEW,0),U)=YSECNEW
  1.  . S $P(^YTT(601.81,YSECNEW,0),U,2)=YSNEWNUM
  1.  . S YSQX=$P(G1,U,3)
  1.  . I (YSQX?1N.N)&($D(^TMP($J,"YSM","O",YSQX))) S $P(^YTT(601.81,YSECNEW,0),U,3)=^TMP($J,"YSM","O",YSQX)
  1.  . S DA=YSECNEW,DIK="^YTT("_YSFILE_"," D IX^DIK
  1.  . S YSDISOLD=$P(G1,U,6)
  1.  . Q:YSDISOLD'?1N.N
  1.  . S YSDISNEW=$$NEW^YTQLIB(YSFILE)
  1.  . S %X="^YTT(601.88,"_YSDISOLD_","
  1.  . S %Y="^YTT(601.88,"_YSDISNEW_","
  1.  . D %XY^%RCR
  1.  . S $P(^YTT(601.88,YSDISNEW,0),U)=YSDISNEW
  1.  . S DA=YSDISNEW,DIK="^YTT(601.88," D IX^DIK
  1.  . S $P(^YTT(601.81,YSECNEW,0),U,6)=YSDISNEW
  1.  Q
  1. SKIP ;skipped qs
  1.  S YSFILE=601.79,N=0
  1.  F  S N=$O(^YTT(601.79,"AC",YSOLDNUM,N)) Q:N'>0  D
  1.  . S G1=^YTT(601.79,N,0)
  1.  . S YSKIPNEW=$$NEW^YTQLIB(YSFILE)
  1.  . S ^YTT(601.79,YSKIPNEW,0)=G1
  1.  . S $P(^YTT(601.79,YSKIPNEW,0),U)=YSKIPNEW
  1.  . S $P(^YTT(601.79,YSKIPNEW,0),U,2)=YSNEWNUM
  1.  . S YSQX=$P(G1,U,3)
  1.  . I (YSQX?1N.N)&($D(^TMP($J,"YSM","O",YSQX))) S $P(^YTT(601.79,YSKIPNEW,0),U,3)=^TMP($J,"YSM","O",YSQX)
  1.  S DA=YSKIPNEW,DIK="^YTT("_YSFILE_"," D IX^DIK
  1.  Q
  1. DISPLAY ;display ques<intro<choice
  1.  S YSFILE=601.88
  1.  S YSN=0 F  S YSN=$O(^YTT(601.76,"AC",YSNEWNUM,YSN)) Q:YSN'>0  D
  1.  . S G=^YTT(601.76,YSN,0)
  1.  . F YSI=7,8,9 S YSDISOLD=$P(G,U,YSI) D:YSDISOLD?1N.N
  1.  .. S YSDISNEW=$$NEW^YTQLIB(YSFILE)
  1.  .. S %X="^YTT("_YSFILE_","_YSDISOLD_","
  1.  .. S %Y="^YTT("_YSFILE_","_YSDISNEW_","
  1.  .. D %XY^%RCR
  1.  .. S $P(^YTT(601.88,YSDISNEW,0),U)=YSDISNEW
  1.  .. S DA=YSDISNEW,DIK="^YTT("_YSFILE_"," D IX^DIK
  1.  .. S $P(^YTT(601.76,YSN,0),U,YSI)=YSDISNEW
  1.  Q
  1. INS ; new one
  1.  S YSFILE=601.71
  1.  S YSOLDNUM=$O(^YTT(601.71,"B",YSOLDNAM,-1))
  1.  S YSNEWNUM=$$NEW^YTQLIB(YSFILE)
  1.  S %X="^YTT("_YSFILE_","_YSOLDNUM_","
  1.  S %Y="^YTT("_YSFILE_","_YSNEWNUM_","
  1.  D %XY^%RCR
  1.  S $P(^YTT(YSFILE,YSNEWNUM,0),U)=YSNEWNAM
  1.  S $P(^YTT(YSFILE,YSNEWNUM,2),U,2)="U"
  1.  S $P(^YTT(YSFILE,YSNEWNUM,2),U,5)=""
  1.  S DA=YSNEWNUM,DIK="^YTT("_YSFILE_"," D IX^DIK
  1.  Q
  1. QUES ;questions, content and intros
  1.  S N=0 F  S N=$O(^YTT(601.76,"AD",YSOLDNUM,N)) Q:N'>0  D
  1.  . S YSQUNEW=$$NEW^YTQLIB(601.72)
  1.  . S %X="^YTT(601.72,"_N_","
  1.  . S %Y="^YTT(601.72,"_YSQUNEW_","
  1.  . D %XY^%RCR
  1.  . S $P(^YTT(601.72,YSQUNEW,0),U)=YSQUNEW
  1.  . S ^TMP($J,"YSM","N",YSQUNEW)=N
  1.  . S ^TMP($J,"YSM","O",N)=YSQUNEW
  1.  . S DA=YSQUNEW,DIK="^YTT(601.72," D IX^DIK ;xref questions
  1.  . S N1=0 F  S N1=$O(^YTT(601.76,"AD",YSOLDNUM,N,N1)) Q:N1'>0  D
  1.  ..S N3=$$NEW^YTQLIB(601.76)
  1.  .. S ^YTT(601.76,N3,0)=^YTT(601.76,N1,0)
  1.  .. S $P(^YTT(601.76,N3,0),U)=N3
  1.  .. S $P(^YTT(601.76,N3,0),U,2)=YSNEWNUM
  1.  .. S DA=N3,DIK="^YTT(601.76," D IX^DIK
  1.  Q
  1. INTRO ;set intros
  1.  S N=0 F  S N=$O(^TMP($J,"YSM","N",N)) Q:N'>0  D
  1.  . S YSOLDI=$P($G(^YTT(601.72,N,2)),U)
  1.  . Q:YSOLDI'?1N.N
  1.  . S YSNEWI=$$NEW^YTQLIB(601.73)
  1.  . S %X="^YTT(601.73,"_YSOLDI_","
  1.  . S %Y="^YTT(601.72,"_YSNEWI_","
  1.  . D %XY^%RCR
  1.  . S $P(^YTT(601.73,YSNEWI,0),U)=YSNEWI
  1.  . S DA=YSNEWI,DIK="^YTT(601.73," D IX^DIK
  1.  . S $P(^YTT(601.72,N,2),U)=YSNEWI
  1.  Q
  1. PARSE ;get old name, new name and national
  1.  S YSOLDNAM=$G(YS("ORIGINAL"))
  1.  I YSOLDNAM="" S YSDATA(1)="[ERROR]",YSDATA(2)="bad orig",YSERR=1 Q  ;-->out
  1.  I '$D(^YTT(601.71,"B",YSOLDNAM)) S YSDATA(1)="[ERROR]",YSDATA(2)="orig not found",YSERR=1 Q  ;-->out
  1.  S YSNEWNAM=$G(YS("NEW"))
  1.  I YSNEWNAM="" S YSDATA(1)="[ERROR]",YSDATA(2)="bad new",YSERR=1 Q  ;-->out
  1.  I $D(^YTT(601.71,"B",YSNEWNAM)) S YSDATA(1)="[ERROR]",YSDATA(2)="new already exits",YSERR=1 Q  ;-->out
  1.  I $L(YSNEWNAM)>50!($L(YSNEWNAM)<3)!'(YSNEWNAM'?1P.E) S YSDATA(1)="[ERROR]",YSDATA(2)="new out out bounds",YSERR=1 Q  ;-->out
  1.  S YSNAT=$G(YS("NATIONAL"),0)
  1.  K YSPROG S:YSNAT=1&($D(^XUSEC("YSPROG",DUZ))) YSPROG=1
  1.  Q