source: FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTQAPI11.m@ 711

YTQAPI11 ;ASF/ALB MHAx API ; 4/3/07 11:03am
 ;;5.01;MENTAL HEALTH;**85**;DEC 30,1994;Build 48
SCORSAVE(YSDATA,YS) ;save results to 601.92
 ; input: AD as administration ID
 ; output: DATA vs ERROR
 N YSAD,DIK,YSG,YSRNEW,Z
 S YSAD=$G(YS("AD"))
 I YSAD'?1N.N S YSDATA(1)="[ERROR]",YSDATA(2)="bad ad num" Q  ;-->out
 I '$D(^YTT(601.84,YSAD)) S YSDATA(1)="[ERROR]",YSDATA(2)="ad not found" Q  ;-->out
 D GETSCORE^YTQAPI8(.YSDATA,.YS)
 I $G(^TMP($J,"YSCOR",1))'="[DATA]" S YSDATA="[ERROR]",YSDATA(2)="getscore err" Q  ;-->out
 ;delete any previous scores for this admin
 S DIK="^YTT(601.92,",DA=0
 F  S DA=$O(^YTT(601.92,"AC",YSAD,DA)) Q:DA'>0  D ^DIK
 ;ADD SCORES
 S Z=1 F  S Z=$O(^TMP($J,"YSCOR",Z)) Q:Z'>0  D
 . S YSG=^TMP($J,"YSCOR",Z)
 . S YSRNEW=$$NEW^YTQLIB(601.92)
 . S ^YTT(601.92,YSRNEW,0)=YSRNEW_U_YSAD_U_$P(YSG,"=")_U_$P(YSG,"=",2)
 . S DA=YSRNEW D IX^DIK
 S YSDATA(1)="[DATA]"
 Q
SCALES ;from copy
 S YSSGOLD=0 F  S N=$O(^YTT(601.86,"AD",YSOLDNUM,YSSGOLD)) Q:YSSGOLD'>0  D
 . S YSSGNEW=$$NEW^YTQLIB(601.86)
 . S ^YTT(601.86,YSSGNEW,0)=^YTT(601.86,YSSGOLD,0)
 . S $P(^YTT(601.86,YSSGNEW,0),U)=YSSGNEW
 . S $P(^YTT(601.86,YSSGNEW,0),U,2)=YSNEWNUM
 . S DA=YSSGNEW,DIK="^YTT(601.86," D IX^DIK
 . S YSSLOLD=0 F  S YSN1=$O(^YTT(601.87,"AD",YSSGOLD,YSSLOLD)) Q:YSSLOLD'>0  D
 .. S YSSLNEW=$$NEW^YTQLIB(601.87)
 .. S ^YTT(601.87,YSSLNEW,0)=^YTT(601.87,YSSLOLD,0)
 .. S $P(^YTT(601.87,YSSLNEW,0),U)=YSSLNEW
 .. S $P(^YTT(601.87,YSSLNEW,0),U,2)=YSSGNEW
 .. S DA=YSSLNEW,DIK="^YTT(601.87," D IX^DIK
 .. S YSKEYOLD=0 F  S YSKEYOLD=$O(^YTT(601.91,"AC",YSSLOLD,YSKEYOLD)) Q:YSKEYOLD'>0  D
 ... S YSKEYNEW=$$NEW^YTQLIB(601.91)
 ... S ^YTT(601.91,YSKEYNEW,0)=^YTT(601.91,YSKEYOLD,0)
 ... S $P(^YTT(601.91,YSKEYNEW,0),U)=YSKEYNEW
 ... S $P(^YTT(601.91,YSKEYNEW,0),U,2)=YSSLNEW
 ... S YSQX=$P(^YTT(601.91,YSKEYNEW,0),U,3)
 ... I (YSQX?1N.N)&($D(^TMP($J,"YSM","O",YSQX))) S $P(^YTT(601.91,YSKEYNEW,0),U,3)=^TMP($J,"YSM","O",YSQX)
 ... S DA=YSKEYNEW,DIK="^YTT(601.91," D IX^DIK
 Q
RULES ;from copy
 S N=$O(^YTT(601.83,"C",YSOLDNUM,N)) Q:N'>0  D
 . S G1=^YTT(601.83,N,0)
 . S YSISRNEW=$$NEW^YTQLIB(YSFILE)
 . S ^YTT(601.83,YSISRNEW,0)=G1
 . S $P(^YTT(601.83,YSISRNEW,0),U)=YSISRNEW
 . S $P(^YTT(601.83,YSISRNEW,0),U,2)=YSNEWNUM
 . S YSQX=$P(G1,U,3)
 . I (YSQX?1N.N)&($D(^TMP($J,"YSM","O",YSQX))) S $P(^YTT(601.83,YSECNEW,0),U,3)=^TMP($J,"YSM","O",YSQX)
 . S DA=YSISRNEW,DIK="^YTT("_YSFILE_"," D IX^DIK
 . ;add rule
 . S YSRULOLD=$P(G,U,4)
 . S G2=^YTT(601.82,YSRULOLD,0)
 . S YSRULNEW=$$NEW^YTQLIB(601.82)
 . S $P(^YTT(601.83,YSISRNEW,0),U,4)=YSRULNEW
 . S ^YTT(601.82,YSRULNEW,0)=G2
 . S $P(^YTT(601.82,YSRULNEW,0),U)=YSRULNEW
 . S YSQX=$P(G2,U,2)
 . I (YSQX?1N.N)&($D(^TMP($J,"YSM","O",YSQX))) S $P(^YTT(601.82,YSRULNEW,0),U,2)=^TMP($J,"YSM","O",YSQX)
 . S YSQX=$P(G2,U,7)
 . I (YSQX?1N.N)&($D(^TMP($J,"YSM","O",YSQX))) S $P(^YTT(601.82,YSRULNEW,0),U,7)=^TMP($J,"YSM","O",YSQX)
 . S DA=YSRULNEW,DIK="^YTT(601.82," D IX^DIK
 Q
FULLWP(YSDATA,YS) ;first line of all WPS
 ;returns a WP field
 ;Input: FILEN(file number), FIELD (WP filed #)
 ;Ouput IEN^WP Text line N
 N N,YSN,YSN1,YSFILEN,YSFIELD
 S YSDATA=$NA(^TMP($J,"YSWP")) K ^TMP($J,"YSWP")
 S YSFILEN=$G(YS("FILEN"),0) I $$VFILE^DILFD(YSFILEN)<1 S ^TMP($J,"YSWP",1)="[ERROR]",^TMP($J,"YSWP",2)="BAD FILE N" Q  ;--->out
 S YSFIELD=$G(YS("FIELD"),0) S N=$$VFIELD^DILFD(YSFILEN,YSFIELD) I N<1 S ^TMP($J,"YSWP",1)="[ERROR]",^TMP($J,"YSWP",2)="BAD field" Q  ;--> out
 S YSN=0,N=1,^TMP($J,"YSWP",1)="[DATA]"
 F  S YSN=$O(^YTT(YSFILEN,YSN)) Q:YSN'>0  D
 . S YSN1=0 F  S YSN1=$O(^YTT(YSFILEN,YSN,YSFIELD,YSN1)) Q:YSN1'>0  D
 .. S N=N+1
 .. S ^TMP($J,"YSWP",N)=YSN_U_$G(^YTT(YSFILEN,YSN,YSFIELD,YSN1,0))
 Q
FINDP(YSDATA,YS) ; patient lookup
 ; input:
 ;   VALUE = value to lookup
 ;   NUMBER= maximum number to find
 ;     Lookup uses multiple index lookup of File #2
 ; output:
 ;   [DATA]^number of records returned
 ;    DFN^patient name^DOB^PID^Gender
 ;
 N DIERR,YSVALUE,NODE,SSN,DSSN,PLID,YSN,YSX,YSNUMBER
 S YSVALUE=$G(YS("VALUE"))
 S YSNUMBER=$G(YS("NUMBER"),"*")
 K ^TMP("YSDATA",$J) S YSDATA=$NA(^TMP("YSDATA",$J))
 D FIND^DIC(2,,".01;.03;.363;.09;.02","PS",YSVALUE,YSNUMBER,"B^BS^BS5^SSN")
 I $G(DIERR) D CLEAN^DILF Q
 S YSN=1,^TMP("YSDATA",$J,YSN)="[DATA]"_U_+^TMP("DILIST",$J,0)
 S YSX=0 F  S YSX=$O(^TMP("DILIST",$J,YSX)) Q:YSX'>0  D
 . S NODE=^TMP("DILIST",$J,YSX,0)
 . ;Apply DOB screen
 . S $P(NODE,U,3)=$$DOB^DPTLK1(+NODE)
 . ;Apply SSN screen
 . S SSN=$$SSN^DPTLK1(+NODE)
 . S DSSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,11)
 . S PLID=$P(NODE,U,4)
 . I $E(SSN,1,9)'?9N S (DSSN,PLID)=SSN
 . S $P(NODE,U,4)=$S($L(PLID)>5:PLID,1:DSSN)
 . ;Move screened data back into output global
 . S YSN=YSN+1,^TMP("YSDATA",$J,YSN)=$P(NODE,U,1,4)_U_$P(NODE,U,6)
 K ^TMP("DILIST",$J)
 Q