YTAPI7 ;ASF/ALB,HIOFO/FT - PSYCH TEST API INCOMPLETES ;9/29/11 15:08
;;5.01;MENTAL HEALTH;**71,60**;Dec 30, 1994;Build 47
;
;Reference to ^XLFDT APIs supported by DBIA #10103
;
SAVEINC(YSDATA,YS) ; save incomplete admins [YTAPI SAVE INCOMPLETES rpc]
N B,R1,R2,R3,DA,DIK,YSNEXT,X,Y,N1,YSADATE,DFN,YSCODE,YSNEXT,YSORDER
D PARSE(.YS)
I '$D(DFN) S YSDATA(1)="[ERROR]",YSDATA(2)="no pt dfn" Q ;--->OUT
I '$D(YSNEXT) S YSDATA(1)="[ERROR]",YSDATA(2)="no next" Q ;---> OUT
I YSCODE=""!'$D(^YTT(601,YSCODE)) S YSDATA(1)="[ERROR]",YSDATA(2)="bad test code" Q ;--->OUT
I YSORDER'?1N.N S YSDATA(1)="[ERROR]",YSDATA(2)="bad ORDERED BY" Q ;--->OUT
SAV1 ;
L +^YTD(601.4,DFN):DILOCKTM
I '$T S YSDATA(1)="[ERROR]",YSDATA(2)="cannot lock record" Q ;--->OUT
I '$D(^YTD(601.4,DFN,0)) D NEWPT I '$D(^YTD(601.4,DFN,0)) S YSDATA(1)="[ERROR]",YSDATA(2)="cannot lock record" Q ;add at dfn level or OUT
S $P(^YTD(601.4,DFN,1,0),U,2)="601.4P"
S:YSCODE>$P(^YTD(601.4,DFN,1,0),U,3) $P(^YTD(601.4,DFN,1,0),U,3)=YSCODE
S $P(^YTD(601.4,DFN,1,0),U,4)=$P(^YTD(601.4,DFN,1,0),U,4)+1
S ^YTD(601.4,DFN,1,YSCODE,0)=YSCODE_"^"_YSADATE_"^^"_YSNEXT_"^"_$P($G(^YTT(601,YSCODE,"Q",YSNEXT,0)),U,2)_"^^"_YSORDER
S:$P(^YTD(601.4,DFN,1,YSCODE,0),U,8)="" $P(^YTD(601.4,DFN,1,YSCODE,0),U,8)=DT
S B="",N1=YSNEXT+.1 ;bottom text
F S N1=$O(^YTT(601,YSCODE,"Q",N1),-1) Q:N1'>0 S B=$G(^YTT(601,YSCODE,"Q",N1,"B")) Q:$D(^YTT(601,YSCODE,"Q",N1,"B"))
I $L(B) S ^YTD(601.4,DFN,1,YSCODE,"B")=B
S ^YTD(601.4,DFN,1,YSCODE,1)=R1
S ^YTD(601.4,DFN,1,YSCODE,2)=R2
S ^YTD(601.4,DFN,1,YSCODE,3)=R3
S DIK="^YTD(601.4,",DA=DFN D IX^DIK ;reindex
L -^YTD(601.4,DFN)
S YSDATA(1)="[DATA]",YSDATA(2)="saved ok"
Q
NEWPT ;new entry to 601.4
L +^YTD(601.4,0):DILOCKTM Q:'$T
S X=^YTD(601.4,0),X(4)=$P(X,U,4),X(3)=$P(X,U,3),X(4)=X(4)+1
S:DFN>X(3) X(3)=DFN
S X=$P(X,U,1,2)_"^"_X(3)_"^"_X(4)
S ^YTD(601.4,0)=X,^YTD(601.4,DFN,0)=DFN,^YTD(601.4,"B",DFN,DFN)=""
L -^YTD(601.4,0)
Q
LISTINC(YSDATA,YS) ;list all incompletes for a pt [YTAPI LIST INCOMPLETES rpc]
N DFN,YSCODE,YSCODEN,X,Y,N,N1,G,YSL,YSADATE,YTLM,YSRSLMT
S YSRSLMT=3
S DFN=$G(YS("DFN"))
I '$D(DFN) S YSDATA(1)="[ERROR]",YSDATA(2)="no pt dfn" Q ;--->OUT
S YSDATA(1)="[DATA]"
S N1=0 F S N1=$O(^YTD(601.4,DFN,1,N1)) Q:N1'>0 D
. S G=^YTD(601.4,DFN,1,N1,0)
. S YSCODE=N1,YSCODEN=$P($G(^YTT(601,N1,0)),U)
. S:YSCODEN?1"CLERK".E YSCODE=$P(G,U,6) S:YSCODE>0 YSCODEN=$P(^YTT(601,YSCODE,0),U)
. Q:$P(^YTT(601,YSCODE,0),U,9)'="T" ;--> OUT ASF 4/27/01
. S YSL(YSCODEN)=YSCODEN
. S (YSADATE,Y)=$P(G,U,2) D DD^%DT S $P(YSL(YSCODEN),U,2)=Y
. S YTLM=YSRSLMT
. I $P($G(^YTT(601,YSCODE,0)),U,16) S YTLM=$P(^(0),U,16)
. S X=$$FMDIFF^XLFDT(DT,YSADATE,1)
. S $P(YSL(YSCODEN),U,3)=$S(X>YTLM:"not restartable",1:"restartable")
S N1=0,N=0 F S N1=$O(YSL(N1)) Q:N1="" D
. S N=N+1
. S YSDATA(N)=YSL(N1)
Q
GETINC(YSDATA,YS) ;get saved data [YTAPI GET INCOMPLETES rpc]
N DFN,YSCODE,YSCLERK,YSCLERKN,YSENT
D PARSE(.YS)
I '$D(DFN) S YSDATA(1)="[ERROR]",YSDATA(2)="no pt dfn" Q ;--->OUT
I YSCODE=""!'$D(^YTT(601,YSCODE)) S YSDATA(1)="[ERROR]",YSDATA(2)="bad test code" Q ;--->OUT
I '$D(^YTD(601.4,DFN)) S YSDATA(1)="[ERROR]",YSDATA(2)="no inc for dfn" Q ;--> OUT
S YSCLERK=$O(^YTT(601,"B","CLERK",0))
S YSCLERKN=$P($G(^YTD(601.4,DFN,1,YSCLERK,0)),U,6)
I '$D(^YTD(601.4,DFN,1,YSCODE))&(YSCODE'=YSCLERKN) S YSDATA(1)="[ERROR]",YSDATA(2)="no data for test" Q ;-->OUT
S YSENT=$S(YSCODE=YSCLERKN:YSCLERK,1:YSCODE)
S YSDATA(1)="[DATA]"
S YSDATA(2)=^YTD(601.4,DFN,1,YSENT,0)
S YSDATA(3)=$G(^YTD(601.4,DFN,1,YSENT,1))
S YSDATA(4)=$G(^YTD(601.4,DFN,1,YSENT,2))
S YSDATA(5)=$G(^YTD(601.4,DFN,1,YSENT,3))
Q
PARSE(YS) ; -- array parsing
S DFN=$G(YS("DFN"))
S YSCODE=$G(YS("CODE"),"ERROR")
S:YSCODE'?1N.N YSCODE=$O(^YTT(601,"B",YSCODE,0))
S YSADATE=$G(YS("ADATE")) S X=YSADATE D ^%DT S YSADATE=Y
S YSORDER=$G(YS("ORDERBY"))
S YSNEXT=$G(YS("NEXT"))
S R1=$G(YS("R1"))
S R2=$G(YS("R2"))
S R3=$G(YS("R3"))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTAPI7 4023 printed Apr 09, 2024@21:14:56 Page 2
YTAPI7 ;ASF/ALB,HIOFO/FT - PSYCH TEST API INCOMPLETES ;9/29/11 15:08
+1 ;;5.01;MENTAL HEALTH;**71,60**;Dec 30, 1994;Build 47
+2 ;
+3 ;Reference to ^XLFDT APIs supported by DBIA #10103
+4 ;
SAVEINC(YSDATA,YS) ; save incomplete admins [YTAPI SAVE INCOMPLETES rpc]
+1 NEW B,R1,R2,R3,DA,DIK,YSNEXT,X,Y,N1,YSADATE,DFN,YSCODE,YSNEXT,YSORDER
+2 DO PARSE(.YS)
+3 ;--->OUT
IF '$DATA(DFN)
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="no pt dfn"
QUIT
+4 ;---> OUT
IF '$DATA(YSNEXT)
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="no next"
QUIT
+5 ;--->OUT
IF YSCODE=""!'$DATA(^YTT(601,YSCODE))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad test code"
QUIT
+6 ;--->OUT
IF YSORDER'?1N.N
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad ORDERED BY"
QUIT
SAV1 ;
+1 LOCK +^YTD(601.4,DFN):DILOCKTM
+2 ;--->OUT
IF '$TEST
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="cannot lock record"
QUIT
+3 ;add at dfn level or OUT
IF '$DATA(^YTD(601.4,DFN,0))
DO NEWPT
IF '$DATA(^YTD(601.4,DFN,0))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="cannot lock record"
QUIT
+4 SET $PIECE(^YTD(601.4,DFN,1,0),U,2)="601.4P"
+5 if YSCODE>$PIECE(^YTD(601.4,DFN,1,0),U,3)
SET $PIECE(^YTD(601.4,DFN,1,0),U,3)=YSCODE
+6 SET $PIECE(^YTD(601.4,DFN,1,0),U,4)=$PIECE(^YTD(601.4,DFN,1,0),U,4)+1
+7 SET ^YTD(601.4,DFN,1,YSCODE,0)=YSCODE_"^"_YSADATE_"^^"_YSNEXT_"^"_$PIECE($GET(^YTT(601,YSCODE,"Q",YSNEXT,0)),U,2)_"^^"_YSORDER
+8 if $PIECE(^YTD(601.4,DFN,1,YSCODE,0),U,8)=""
SET $PIECE(^YTD(601.4,DFN,1,YSCODE,0),U,8)=DT
+9 ;bottom text
SET B=""
SET N1=YSNEXT+.1
+10 FOR
SET N1=$ORDER(^YTT(601,YSCODE,"Q",N1),-1)
if N1'>0
QUIT
SET B=$GET(^YTT(601,YSCODE,"Q",N1,"B"))
if $DATA(^YTT(601,YSCODE,"Q",N1,"B"))
QUIT
+11 IF $LENGTH(B)
SET ^YTD(601.4,DFN,1,YSCODE,"B")=B
+12 SET ^YTD(601.4,DFN,1,YSCODE,1)=R1
+13 SET ^YTD(601.4,DFN,1,YSCODE,2)=R2
+14 SET ^YTD(601.4,DFN,1,YSCODE,3)=R3
+15 ;reindex
SET DIK="^YTD(601.4,"
SET DA=DFN
DO IX^DIK
+16 LOCK -^YTD(601.4,DFN)
+17 SET YSDATA(1)="[DATA]"
SET YSDATA(2)="saved ok"
+18 QUIT
NEWPT ;new entry to 601.4
+1 LOCK +^YTD(601.4,0):DILOCKTM
if '$TEST
QUIT
+2 SET X=^YTD(601.4,0)
SET X(4)=$PIECE(X,U,4)
SET X(3)=$PIECE(X,U,3)
SET X(4)=X(4)+1
+3 if DFN>X(3)
SET X(3)=DFN
+4 SET X=$PIECE(X,U,1,2)_"^"_X(3)_"^"_X(4)
+5 SET ^YTD(601.4,0)=X
SET ^YTD(601.4,DFN,0)=DFN
SET ^YTD(601.4,"B",DFN,DFN)=""
+6 LOCK -^YTD(601.4,0)
+7 QUIT
LISTINC(YSDATA,YS) ;list all incompletes for a pt [YTAPI LIST INCOMPLETES rpc]
+1 NEW DFN,YSCODE,YSCODEN,X,Y,N,N1,G,YSL,YSADATE,YTLM,YSRSLMT
+2 SET YSRSLMT=3
+3 SET DFN=$GET(YS("DFN"))
+4 ;--->OUT
IF '$DATA(DFN)
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="no pt dfn"
QUIT
+5 SET YSDATA(1)="[DATA]"
+6 SET N1=0
FOR
SET N1=$ORDER(^YTD(601.4,DFN,1,N1))
if N1'>0
QUIT
Begin DoDot:1
+7 SET G=^YTD(601.4,DFN,1,N1,0)
+8 SET YSCODE=N1
SET YSCODEN=$PIECE($GET(^YTT(601,N1,0)),U)
+9 if YSCODEN?1"CLERK".E
SET YSCODE=$PIECE(G,U,6)
if YSCODE>0
SET YSCODEN=$PIECE(^YTT(601,YSCODE,0),U)
+10 ;--> OUT ASF 4/27/01
if $PIECE(^YTT(601,YSCODE,0),U,9)'="T"
QUIT
+11 SET YSL(YSCODEN)=YSCODEN
+12 SET (YSADATE,Y)=$PIECE(G,U,2)
DO DD^%DT
SET $PIECE(YSL(YSCODEN),U,2)=Y
+13 SET YTLM=YSRSLMT
+14 IF $PIECE($GET(^YTT(601,YSCODE,0)),U,16)
SET YTLM=$PIECE(^(0),U,16)
+15 SET X=$$FMDIFF^XLFDT(DT,YSADATE,1)
+16 SET $PIECE(YSL(YSCODEN),U,3)=$SELECT(X>YTLM:"not restartable",1:"restartable")
End DoDot:1
+17 SET N1=0
SET N=0
FOR
SET N1=$ORDER(YSL(N1))
if N1=""
QUIT
Begin DoDot:1
+18 SET N=N+1
+19 SET YSDATA(N)=YSL(N1)
End DoDot:1
+20 QUIT
GETINC(YSDATA,YS) ;get saved data [YTAPI GET INCOMPLETES rpc]
+1 NEW DFN,YSCODE,YSCLERK,YSCLERKN,YSENT
+2 DO PARSE(.YS)
+3 ;--->OUT
IF '$DATA(DFN)
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="no pt dfn"
QUIT
+4 ;--->OUT
IF YSCODE=""!'$DATA(^YTT(601,YSCODE))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad test code"
QUIT
+5 ;--> OUT
IF '$DATA(^YTD(601.4,DFN))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="no inc for dfn"
QUIT
+6 SET YSCLERK=$ORDER(^YTT(601,"B","CLERK",0))
+7 SET YSCLERKN=$PIECE($GET(^YTD(601.4,DFN,1,YSCLERK,0)),U,6)
+8 ;-->OUT
IF '$DATA(^YTD(601.4,DFN,1,YSCODE))&(YSCODE'=YSCLERKN)
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="no data for test"
QUIT
+9 SET YSENT=$SELECT(YSCODE=YSCLERKN:YSCLERK,1:YSCODE)
+10 SET YSDATA(1)="[DATA]"
+11 SET YSDATA(2)=^YTD(601.4,DFN,1,YSENT,0)
+12 SET YSDATA(3)=$GET(^YTD(601.4,DFN,1,YSENT,1))
+13 SET YSDATA(4)=$GET(^YTD(601.4,DFN,1,YSENT,2))
+14 SET YSDATA(5)=$GET(^YTD(601.4,DFN,1,YSENT,3))
+15 QUIT
PARSE(YS) ; -- array parsing
+1 SET DFN=$GET(YS("DFN"))
+2 SET YSCODE=$GET(YS("CODE"),"ERROR")
+3 if YSCODE'?1N.N
SET YSCODE=$ORDER(^YTT(601,"B",YSCODE,0))
+4 SET YSADATE=$GET(YS("ADATE"))
SET X=YSADATE
DO ^%DT
SET YSADATE=Y
+5 SET YSORDER=$GET(YS("ORDERBY"))
+6 SET YSNEXT=$GET(YS("NEXT"))
+7 SET R1=$GET(YS("R1"))
+8 SET R2=$GET(YS("R2"))
+9 SET R3=$GET(YS("R3"))
+10 QUIT
