- YTAPI ;ALB/ASF- PSYCH TEST API ;2/27/04 15:44
- ;;5.01;MENTAL HEALTH;**53,71,76,77**;Dec 30, 1994
- PARSE(YS) ; -- array parsing
- S DFN=$G(YS("DFN"))
- S YSCODE=$G(YS("CODE"))
- S:YSCODE?1N.N YSCODE=$P($G(^YTT(601,YSCODE,0),"ERROR"),U)
- S YSADATE=$G(YS("ADATE")) S X=YSADATE,%DT="T" D ^%DT S YSADATE=Y
- S YSSCALE=$G(YS("SCALE"))
- S YSBEG=$G(YS("BEGIN")) S:YSBEG="" YSBEG="01/01/1970" S X=YSBEG,%DT="T" D ^%DT S YSBEG=Y ;ASF 1/30/04
- S YSEND=$G(YS("END")) S:YSEND="" YSEND="01/01/2099" S X=YSEND,%DT="T" D ^%DT S YSEND=Y ;ASF 1/30/04
- S YSLIMIT=$G(YS("LIMIT"),999)
- S YSSTAFF=$G(YS("STAFF"))
- S R1=$G(YS("R1"))
- S R2=$G(YS("R2"))
- S R3=$G(YS("R3"))
- K %DT
- Q
- LISTALL(YSDATA,YS) ;
- N N,N2,N4,YSAA,I,II,DFN,YSCODE,YSADATE,YSSCALE,YSBED,YSEND,YSJJ,YSLIMIT
- N IFN,R3,SFN1,SFN2,YSBEG,YSCK,YSDFN,YSED,YSIFN,YSINUM,YSITEM,YSN2,YSNODE,YSPRIV,YSQT,YSR,YSSONE,YSSTAFF,YSTYPE
- D PARSE(.YS)
- I DFN'>0!('$D(^DPT(DFN))) S YSDATA(1)="[ERROR]",YSDATA(2)="BAD DFN" Q
- K YSDATA S YSDATA(1)="[DATA]"
- S N=0 F S N=$O(^YTD(601.2,DFN,1,N)) Q:N'>0 D
- . I $P(^YTT(601,N,0),U,9)="I" QUIT
- . I $D(^YTT(601,N)) S N2=YSBEG-.1 F S N2=$O(^YTD(601.2,DFN,1,N,1,N2)) Q:N2'>0!(N2>YSEND) D
- .. S X=^YTT(601,N,0),N4=$P(X,U)
- .. I N4="MMPI",$D(^YTD(601.2,DFN,1,N,1,N2,99)),^(99)="MMPIR" S N4="MMPR"
- .. S YSPRIV="P" S:$P(X,U,10)="Y" YSPRIV="E" S:$P(X,U,9)="I" YSPRIV="E" ;ASF 4/18/01
- .. S YSAA(9999999-N2,N4)=YSPRIV_U_N ;ASF 9/9/03
- .. Q
- I YSCODE="GAF" D GAF
- I YSCODE="ASI" D ASI ;ASF 9/9/03
- S I=0,N=1 F S I=$O(YSAA(I)) Q:I'>0 S II="" F S II=$O(YSAA(I,II)) Q:II="" D SET(9999999-I_U_$$FMTE^XLFDT(9999999-I,"5ZD")_U_II_U_YSAA(I,II)) ;ASF 4/18/01
- Q
- GAF ;
- N YSJJ,YSDD,X,Y,YSX,YSN
- S YSDD=9999999-YSEND-.00001
- F YSJJ=1:1:YSLIMIT S YSDD=$O(^YSD(627.8,"AX5",DFN,YSDD)) Q:YSDD'>0!(YSDD>(9999999-YSBEG)) D
- . S YSN=0 F S YSN=$O(^YSD(627.8,"AX5",DFN,YSDD,YSN)) Q:YSN'>0 D
- .. S YSX=$P($G(^YSD(627.8,YSN,60)),U,3)_"^^"_$$EXTERNAL^DILFD(627.8,.04,"",$P($G(^YSD(627.8,YSN,0)),U,4))_U_$G(^YSD(627.8,YSN,80,1,0))
- .. S YSAA(YSDD,"GAF")=9999999-YSDD_"^GAF^"_YSX
- Q
- ASI ;
- Q:'$D(^YSTX(604,"C",DFN))
- S IFN="A" F YSJJ=1:1:YSLIMIT S IFN=$O(^YSTX(604,"C",DFN,IFN),-1) Q:IFN'>0 D
- . Q:'$D(^YSTX(604,IFN,.5)) ; no sig
- . S N2=$P($G(^YSTX(604,IFN,0)),U,5)
- . I N2>YSEND!(N2<YSBEG) Q ;not in range
- . S YSSONE="^^^"
- . S:YSSCALE=1 YSSONE="^Medical^"_$$GET1^DIQ(604,IFN_",",8.12)_U_$$GET1^DIQ(604,IFN_",",.61)
- . S:YSSCALE=2 YSSONE="^Employment^"_$$GET1^DIQ(604,IFN_",",9.34)_U_$$GET1^DIQ(604,IFN_",",.62)
- . S:YSSCALE=3 YSSONE="^Alcohol^"_$$GET1^DIQ(604,IFN_",",11.18)_U_$$GET1^DIQ(604,IFN_",",.63)
- . S:YSSCALE=4 YSSONE="^Drug^"_$$GET1^DIQ(604,IFN_",",11.185)_U_$$GET1^DIQ(604,IFN_",",.635)
- . S:YSSCALE=5 YSSONE="^Legal^"_$$GET1^DIQ(604,IFN_",",14.34)_U_$$GET1^DIQ(604,IFN_",",.64)
- . S:YSSCALE=6 YSSONE="^Family^"_$$GET1^DIQ(604,IFN_",",18.29)_U_$$GET1^DIQ(604,IFN_",",.65)
- . S:YSSCALE=7 YSSONE="^Psychiatric^"_$$GET1^DIQ(604,IFN_",",19.33)_U_$$GET1^DIQ(604,IFN_",",.66)
- . S YSAA(9999999-N2,"ASI")=N2_U_$$FMTE^XLFDT(N2,"5ZD")_YSSONE_U_IFN
- Q
- SET(X) ;
- S N=N+1
- S YSDATA(N)=X
- Q
- LISTONE(YSDATA,YS) ;
- N YSLIMIT,YSJJ,YSSONE,S,R,N,YSN2,N4,I,II,DFN,YSCODE,YSADATE,YSSCALE,YSBED,YSEND,YSAA
- N IFN,R1,R2,R3,SFN1,SFN2,YSBEG,YSCK,YSDFN,YSED,YSIFN,YSINUM,YSITEM,YSN2,YSNODE,YSPRIV,YSQT,YSR,YSSTAFF,YSTYPE,YSET
- D PARSE(.YS)
- K YSDATA
- I DFN'>0!('$D(^DPT(DFN))) S YSDATA(1)="[ERROR]",YSDATA(2)="BAD DFN" Q
- I '$D(^YTT(601,"B",YSCODE))&(YSCODE'="ASI")&(YSCODE'="GAF") S YSDATA(1)="[ERROR]",YSDATA(2)="INCORRECT TEST CODE" Q
- S YSET=-1 S:YSCODE'="ASI"&(YSCODE'="GAF") YSET=$O(^YTT(601,"B",YSCODE,""))
- S YSDATA(1)="[DATA]"
- I $D(^YTT(601,YSET)) S YSN2=YSEND+.1 F YSJJ=1:1:YSLIMIT S YSN2=$O(^YTD(601.2,DFN,1,YSET,1,YSN2),-1) Q:YSN2'>0!(YSN2<YSBEG) D
- . K YSSONE S YSSONE=""
- . D PRIV^YTAPI2
- . I YSSCALE'=""&(YSPRIV=1) D
- .. S YSADATE=YSN2
- .. D SCOR1^YTAPI2
- .. D SF^YTAPI2
- .. S YSSCALE=$G(YS("SCALE"))
- . S:$D(YSSCALE)&(YSSCALE'="") YSSONE=$S($D(YSSONE(YSSCALE)):U_$P(YSSONE(YSSCALE),U,2,99),1:"")
- . S YSAA(9999999-YSN2,YSCODE)=YSN2_YSSONE
- . Q
- I YSCODE="ASI" D ASI
- I YSCODE="GAF" D GAF
- S I=0,N=1 F S I=$O(YSAA(I)) Q:I'>0 S II="" F S II=$O(YSAA(I,II)) Q:II="" D
- . S X=$P(YSAA(I,II),U)_U_$$FMTE^XLFDT($P(YSAA(I,II),U),"5ZD")_U_II
- . S:$P(YSAA(I,II),U,2)'="" X=X_U_$P(YSAA(I,II),U,2,9)
- . D SET(X)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTAPI 4352 printed Feb 18, 2025@23:43:01 Page 2
- YTAPI ;ALB/ASF- PSYCH TEST API ;2/27/04 15:44
- +1 ;;5.01;MENTAL HEALTH;**53,71,76,77**;Dec 30, 1994
- PARSE(YS) ; -- array parsing
- +1 SET DFN=$GET(YS("DFN"))
- +2 SET YSCODE=$GET(YS("CODE"))
- +3 if YSCODE?1N.N
- SET YSCODE=$PIECE($GET(^YTT(601,YSCODE,0),"ERROR"),U)
- +4 SET YSADATE=$GET(YS("ADATE"))
- SET X=YSADATE
- SET %DT="T"
- DO ^%DT
- SET YSADATE=Y
- +5 SET YSSCALE=$GET(YS("SCALE"))
- +6 ;ASF 1/30/04
- SET YSBEG=$GET(YS("BEGIN"))
- if YSBEG=""
- SET YSBEG="01/01/1970"
- SET X=YSBEG
- SET %DT="T"
- DO ^%DT
- SET YSBEG=Y
- +7 ;ASF 1/30/04
- SET YSEND=$GET(YS("END"))
- if YSEND=""
- SET YSEND="01/01/2099"
- SET X=YSEND
- SET %DT="T"
- DO ^%DT
- SET YSEND=Y
- +8 SET YSLIMIT=$GET(YS("LIMIT"),999)
- +9 SET YSSTAFF=$GET(YS("STAFF"))
- +10 SET R1=$GET(YS("R1"))
- +11 SET R2=$GET(YS("R2"))
- +12 SET R3=$GET(YS("R3"))
- +13 KILL %DT
- +14 QUIT
- LISTALL(YSDATA,YS) ;
- +1 NEW N,N2,N4,YSAA,I,II,DFN,YSCODE,YSADATE,YSSCALE,YSBED,YSEND,YSJJ,YSLIMIT
- +2 NEW IFN,R3,SFN1,SFN2,YSBEG,YSCK,YSDFN,YSED,YSIFN,YSINUM,YSITEM,YSN2,YSNODE,YSPRIV,YSQT,YSR,YSSONE,YSSTAFF,YSTYPE
- +3 DO PARSE(.YS)
- +4 IF DFN'>0!('$DATA(^DPT(DFN)))
- SET YSDATA(1)="[ERROR]"
- SET YSDATA(2)="BAD DFN"
- QUIT
- +5 KILL YSDATA
- SET YSDATA(1)="[DATA]"
- +6 SET N=0
- FOR
- SET N=$ORDER(^YTD(601.2,DFN,1,N))
- if N'>0
- QUIT
- Begin DoDot:1
- +7 IF $PIECE(^YTT(601,N,0),U,9)="I"
- QUIT
- +8 IF $DATA(^YTT(601,N))
- SET N2=YSBEG-.1
- FOR
- SET N2=$ORDER(^YTD(601.2,DFN,1,N,1,N2))
- if N2'>0!(N2>YSEND)
- QUIT
- Begin DoDot:2
- +9 SET X=^YTT(601,N,0)
- SET N4=$PIECE(X,U)
- +10 IF N4="MMPI"
- IF $DATA(^YTD(601.2,DFN,1,N,1,N2,99))
- IF ^(99)="MMPIR"
- SET N4="MMPR"
- +11 ;ASF 4/18/01
- SET YSPRIV="P"
- if $PIECE(X,U,10)="Y"
- SET YSPRIV="E"
- if $PIECE(X,U,9)="I"
- SET YSPRIV="E"
- +12 ;ASF 9/9/03
- SET YSAA(9999999-N2,N4)=YSPRIV_U_N
- +13 QUIT
- End DoDot:2
- End DoDot:1
- +14 IF YSCODE="GAF"
- DO GAF
- +15 ;ASF 9/9/03
- IF YSCODE="ASI"
- DO ASI
- +16 ;ASF 4/18/01
- SET I=0
- SET N=1
- FOR
- SET I=$ORDER(YSAA(I))
- if I'>0
- QUIT
- SET II=""
- FOR
- SET II=$ORDER(YSAA(I,II))
- if II=""
- QUIT
- DO SET(9999999-I_U_$$FMTE^XLFDT(9999999-I,"5ZD")_U_II_U_YSAA(I,II))
- +17 QUIT
- GAF ;
- +1 NEW YSJJ,YSDD,X,Y,YSX,YSN
- +2 SET YSDD=9999999-YSEND-.00001
- +3 FOR YSJJ=1:1:YSLIMIT
- SET YSDD=$ORDER(^YSD(627.8,"AX5",DFN,YSDD))
- if YSDD'>0!(YSDD>(9999999-YSBEG))
- QUIT
- Begin DoDot:1
- +4 SET YSN=0
- FOR
- SET YSN=$ORDER(^YSD(627.8,"AX5",DFN,YSDD,YSN))
- if YSN'>0
- QUIT
- Begin DoDot:2
- +5 SET YSX=$PIECE($GET(^YSD(627.8,YSN,60)),U,3)_"^^"_$$EXTERNAL^DILFD(627.8,.04,"",$PIECE($GET(^YSD(627.8,YSN,0)),U,4))_U_$GET(^YSD(627.8,YSN,80,1,0))
- +6 SET YSAA(YSDD,"GAF")=9999999-YSDD_"^GAF^"_YSX
- End DoDot:2
- End DoDot:1
- +7 QUIT
- ASI ;
- +1 if '$DATA(^YSTX(604,"C",DFN))
- QUIT
- +2 SET IFN="A"
- FOR YSJJ=1:1:YSLIMIT
- SET IFN=$ORDER(^YSTX(604,"C",DFN,IFN),-1)
- if IFN'>0
- QUIT
- Begin DoDot:1
- +3 ; no sig
- if '$DATA(^YSTX(604,IFN,.5))
- QUIT
- +4 SET N2=$PIECE($GET(^YSTX(604,IFN,0)),U,5)
- +5 ;not in range
- IF N2>YSEND!(N2<YSBEG)
- QUIT
- +6 SET YSSONE="^^^"
- +7 if YSSCALE=1
- SET YSSONE="^Medical^"_$$GET1^DIQ(604,IFN_",",8.12)_U_$$GET1^DIQ(604,IFN_",",.61)
- +8 if YSSCALE=2
- SET YSSONE="^Employment^"_$$GET1^DIQ(604,IFN_",",9.34)_U_$$GET1^DIQ(604,IFN_",",.62)
- +9 if YSSCALE=3
- SET YSSONE="^Alcohol^"_$$GET1^DIQ(604,IFN_",",11.18)_U_$$GET1^DIQ(604,IFN_",",.63)
- +10 if YSSCALE=4
- SET YSSONE="^Drug^"_$$GET1^DIQ(604,IFN_",",11.185)_U_$$GET1^DIQ(604,IFN_",",.635)
- +11 if YSSCALE=5
- SET YSSONE="^Legal^"_$$GET1^DIQ(604,IFN_",",14.34)_U_$$GET1^DIQ(604,IFN_",",.64)
- +12 if YSSCALE=6
- SET YSSONE="^Family^"_$$GET1^DIQ(604,IFN_",",18.29)_U_$$GET1^DIQ(604,IFN_",",.65)
- +13 if YSSCALE=7
- SET YSSONE="^Psychiatric^"_$$GET1^DIQ(604,IFN_",",19.33)_U_$$GET1^DIQ(604,IFN_",",.66)
- +14 SET YSAA(9999999-N2,"ASI")=N2_U_$$FMTE^XLFDT(N2,"5ZD")_YSSONE_U_IFN
- End DoDot:1
- +15 QUIT
- SET(X) ;
- +1 SET N=N+1
- +2 SET YSDATA(N)=X
- +3 QUIT
- LISTONE(YSDATA,YS) ;
- +1 NEW YSLIMIT,YSJJ,YSSONE,S,R,N,YSN2,N4,I,II,DFN,YSCODE,YSADATE,YSSCALE,YSBED,YSEND,YSAA
- +2 NEW IFN,R1,R2,R3,SFN1,SFN2,YSBEG,YSCK,YSDFN,YSED,YSIFN,YSINUM,YSITEM,YSN2,YSNODE,YSPRIV,YSQT,YSR,YSSTAFF,YSTYPE,YSET
- +3 DO PARSE(.YS)
- +4 KILL YSDATA
- +5 IF DFN'>0!('$DATA(^DPT(DFN)))
- SET YSDATA(1)="[ERROR]"
- SET YSDATA(2)="BAD DFN"
- QUIT
- +6 IF '$DATA(^YTT(601,"B",YSCODE))&(YSCODE'="ASI")&(YSCODE'="GAF")
- SET YSDATA(1)="[ERROR]"
- SET YSDATA(2)="INCORRECT TEST CODE"
- QUIT
- +7 SET YSET=-1
- if YSCODE'="ASI"&(YSCODE'="GAF")
- SET YSET=$ORDER(^YTT(601,"B",YSCODE,""))
- +8 SET YSDATA(1)="[DATA]"
- +9 IF $DATA(^YTT(601,YSET))
- SET YSN2=YSEND+.1
- FOR YSJJ=1:1:YSLIMIT
- SET YSN2=$ORDER(^YTD(601.2,DFN,1,YSET,1,YSN2),-1)
- if YSN2'>0!(YSN2<YSBEG)
- QUIT
- Begin DoDot:1
- +10 KILL YSSONE
- SET YSSONE=""
- +11 DO PRIV^YTAPI2
- +12 IF YSSCALE'=""&(YSPRIV=1)
- Begin DoDot:2
- +13 SET YSADATE=YSN2
- +14 DO SCOR1^YTAPI2
- +15 DO SF^YTAPI2
- +16 SET YSSCALE=$GET(YS("SCALE"))
- End DoDot:2
- +17 if $DATA(YSSCALE)&(YSSCALE'="")
- SET YSSONE=$SELECT($DATA(YSSONE(YSSCALE)):U_$PIECE(YSSONE(YSSCALE),U,2,99),1:"")
- +18 SET YSAA(9999999-YSN2,YSCODE)=YSN2_YSSONE
- +19 QUIT
- End DoDot:1
- +20 IF YSCODE="ASI"
- DO ASI
- +21 IF YSCODE="GAF"
- DO GAF
- +22 SET I=0
- SET N=1
- FOR
- SET I=$ORDER(YSAA(I))
- if I'>0
- QUIT
- SET II=""
- FOR
- SET II=$ORDER(YSAA(I,II))
- if II=""
- QUIT
- Begin DoDot:1
- +23 SET X=$PIECE(YSAA(I,II),U)_U_$$FMTE^XLFDT($PIECE(YSAA(I,II),U),"5ZD")_U_II
- +24 if $PIECE(YSAA(I,II),U,2)'=""
- SET X=X_U_$PIECE(YSAA(I,II),U,2,9)
- +25 DO SET(X)
- End DoDot:1
- +26 QUIT