YTAPI8 ;ASF/ALB- ASI PROCEEDURES ;7/26/01 11:35
;;5.01;MENTAL HEALTH;**67,71**;Dec 30, 1994
ADDER(YSDATA) ;add new record
N DIC,DLAYGO,X,Y
S DLAYGO=604,DIC(0)="L",DIC="^YSTX(604,",X="NEW"
D ^DIC
I Y'>0 S YSDATA(1)="[ERROR]",YSDATA(2)=-1 Q ;->out
S YSDATA(1)="[DATA]",YSDATA(2)=+Y
Q
;GET ASI STORED DATA
GETASI(YSDATA,YS) ;NEEDS IEN FOR FILE 604,DFN
;Field #^Question^Required^Answer
N YSIEN,DFN,G,N,N1,X,YSN
S YSIEN=$G(YS("IEN"))
S DFN=$G(YS("DFN"))
I YSIEN'>0!('$D(^YSTX(604,YSIEN))) S YSDATA(1)="[ERROR]",YSDATA(2)="BAD IEN" Q ; --->
I $P(^YSTX(604,YSIEN,0),U,2)'=DFN S YSDATA(1)="[ERROR]",YSDATA(2)="BAD DFN MATCH" Q ;--->OUT
S YSDATA(1)="[DATA]"
S YSDATA(2)=.02_U_"NAME"_U_1_U_$$GET1^DIQ(604,YSIEN_",",.02,"E")
S YSDATA(3)=.51_U_"ELECTRONICALLY SIGNED"_U_1_U_$$GET1^DIQ(604,YSIEN_",",.51,"E")
S YSN=3
DCROSS S N=0
F S N=$O(^YSTX(604.66,"D",N)) Q:N'>0 D
. S N1=$O(^YSTX(604.66,"D",N,0))
. S G=^YSTX(604.66,N1,0)
. S X=$$GET1^DIQ(604,YSIEN_",",N,"E")
. S YSN=YSN+1
. S YSDATA(YSN)=N_U_$P(G,U,2)_U_$P(G,U,8)_U_X
Q
LISTASI(YSDATA,YS) ;ASI LISTER
;REQUIRES: DFN
;RETURNS: IEN^DATE OF INTERVIEW^CLASS^SPECIAL^ESIGNED
;0 RETURNED IF NO ADMINS
N DFN,YSIEN,YSN
S DFN=$G(YS("DFN"))
I DFN<1 S YSDATA(1)="[ERROR]",YSDATA(2)="BAD DFN" Q ;--->OUT
S YSDATA(1)="[DATA]",YSDATA(2)=0
S YSN=1
S YSIEN=0
F S YSIEN=$O(^YSTX(604,"C",DFN,YSIEN)) Q:YSIEN'>0 D
. S YSN=YSN+1
. S YSDATA(YSN)=YSIEN_U_$$FMTE^XLFDT($$GET1^DIQ(604,YSIEN_",",.05,"I"),"5ZD")_U_$$GET1^DIQ(604,YSIEN_",",.04,"E")_U_$$GET1^DIQ(604,YSIEN_",",.11,"E")_U_$$GET1^DIQ(604,YSIEN_",",.51,"E")_U_$$GET1^DIQ(604,YSIEN_",",.09,"E")
Q
SIGNOK(YSDATA,YSIEN) ; all reqiured fields
;ysflag 1= ok 0= missing 2=SPECIAL
N N1,YSASCLS,X,YSASFLD,YSF,YSASSPL,YSN,YSFLAG
S YSFLAG=1
I '$D(^YSTX(604,YSIEN,0)) S YSDATA(1)="[ERROR]",YSDATA(2)="BAD IEN" Q
S YSDATA(1)="[DATA]",YSDATA(2)="1^OK TO SIGN"
S YSN=2
S YSASCLS=$$GET1^DIQ(604,YSIEN_",",.04,"I")
S YSASCLS=YSASCLS+3
S N1=0 F S N1=$O(^YSTX(604.66,N1)) Q:N1'>0 D:($P(^YSTX(604.66,N1,0),U,8)&($P(^YSTX(604.66,N1,0),U,YSASCLS)))
. S YSASFLD=$P(^YSTX(604.66,N1,0),U,3)
. D TYPE
.; S YSF=$S(YSASFLD>10.02&(YSASFLD<10.44):"I",$P(^DD(604,YSASFLD,0),U,2)?1"P".E:"",1:"I")
. S YSF=$S(YSASFLD>10.02&(YSASFLD<10.44):"I",YSTYPE=1:"",1:"I")
. S X=$$GET1^DIQ(604,YSIEN,YSASFLD,YSF)
. S:X="" YSFLAG=0,YSN=YSN+1,YSDATA(YSN)=^YSTX(604,66,N1,0)
S X=$$GET1^DIQ(604,YSIEN,YSASFLD,.11)
S:X="X"!(X="N") YSFLAG=2
S:YSFLAG=0 YSDATA(2)="0^MISSING REQUIRED FIELDS"
S:YSFLAG=2 YSDATA(2)="2^A G12 RECORD"
Q
TYPE ;check field type
;O = NOT A POINTER 1 = POINTER
N YSFLD,YSTYPE
S YSTYPE=0
D FIELD^DID(604,YSASFLD,"","TYPE","YSFLD")
S:YSFLD("TYPE")="POINTER" YSTYPE=1
Q
SIGN(YSDATA,YS) ; API for /es/
N YSCODE,YSASINTV,YSASTRS,VALID
S YSCODE=$G(YS("CODE"))
I YSCODE="" S YSDATA(1)="[ERROR]",YSDATA(2)="NO SIG SENT" Q
S YSIEN=$G(YS("YSIEN"))
I YSIEN'>0 S YSDATA(1)="[ERROR]",YSDATA(2)="NO REC NUMBER" Q
I '$D(^YSTX(604,YSIEN)) S YSDATA(1)="[ERROR]",YSDATA(2)="NO REC FOUND" Q
S VALID=$$VALIDATE($$DECRYP^XUSRB1(YSCODE))
I +VALID'>0 S YSDATA(1)="[DATA]",YSDATA(2)="0^Bad EScode, not signed" Q
S YSASINTV=$$GET1^DIQ(604,YSIEN_",",.09,"I") ;INTERVERER
S YSASTRS=$$GET1^DIQ(604,YSIEN_",",.14,"I") ;TRANSCRIBER
I YSASINTV=DUZ,DUZ>0 D Q ;---> OUT
. D CR^YSASCR(YSIEN,YSASINTV,"")
. S YSDATA(1)="[DATA]",YSDATA(2)="1^ASI SIGNED"
I YSASTRS=DUZ,DUZ>0 D Q ;---> OUT
. D CONV^YSASCR(YSIEN,YSASINTV)
. D BUL^YSASBUL(YSIEN,YSASTRS,YSASINTV)
. S YSDATA(1)="[DATA]",YSDATA(2)="0^TRANSCRIBER SEND BULLETIN"
S YSDATA(1)="[ERROR]",YSDATA(2)="BAD LOGIC"
Q
VALIDATE(X) ; Validate /es/-code
N YSY S YSY=0
D HASH^XUSHSHP I X]"",(X=$P($G(^VA(200,+DUZ,20)),U,4)) S YSY=1
Q YSY
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTAPI8 3801 printed Oct 16, 2024@18:17:36 Page 2
YTAPI8 ;ASF/ALB- ASI PROCEEDURES ;7/26/01 11:35
+1 ;;5.01;MENTAL HEALTH;**67,71**;Dec 30, 1994
ADDER(YSDATA) ;add new record
+1 NEW DIC,DLAYGO,X,Y
+2 SET DLAYGO=604
SET DIC(0)="L"
SET DIC="^YSTX(604,"
SET X="NEW"
+3 DO ^DIC
+4 ;->out
IF Y'>0
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)=-1
QUIT
+5 SET YSDATA(1)="[DATA]"
SET YSDATA(2)=+Y
+6 QUIT
+7 ;GET ASI STORED DATA
GETASI(YSDATA,YS) ;NEEDS IEN FOR FILE 604,DFN
+1 ;Field #^Question^Required^Answer
+2 NEW YSIEN,DFN,G,N,N1,X,YSN
+3 SET YSIEN=$GET(YS("IEN"))
+4 SET DFN=$GET(YS("DFN"))
+5 ; --->
IF YSIEN'>0!('$DATA(^YSTX(604,YSIEN)))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="BAD IEN"
QUIT
+6 ;--->OUT
IF $PIECE(^YSTX(604,YSIEN,0),U,2)'=DFN
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="BAD DFN MATCH"
QUIT
+7 SET YSDATA(1)="[DATA]"
+8 SET YSDATA(2)=.02_U_"NAME"_U_1_U_$$GET1^DIQ(604,YSIEN_",",.02,"E")
+9 SET YSDATA(3)=.51_U_"ELECTRONICALLY SIGNED"_U_1_U_$$GET1^DIQ(604,YSIEN_",",.51,"E")
+10 SET YSN=3
DCROSS SET N=0
+1 FOR
SET N=$ORDER(^YSTX(604.66,"D",N))
if N'>0
QUIT
Begin DoDot:1
+2 SET N1=$ORDER(^YSTX(604.66,"D",N,0))
+3 SET G=^YSTX(604.66,N1,0)
+4 SET X=$$GET1^DIQ(604,YSIEN_",",N,"E")
+5 SET YSN=YSN+1
+6 SET YSDATA(YSN)=N_U_$PIECE(G,U,2)_U_$PIECE(G,U,8)_U_X
End DoDot:1
+7 QUIT
LISTASI(YSDATA,YS) ;ASI LISTER
+1 ;REQUIRES: DFN
+2 ;RETURNS: IEN^DATE OF INTERVIEW^CLASS^SPECIAL^ESIGNED
+3 ;0 RETURNED IF NO ADMINS
+4 NEW DFN,YSIEN,YSN
+5 SET DFN=$GET(YS("DFN"))
+6 ;--->OUT
IF DFN<1
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="BAD DFN"
QUIT
+7 SET YSDATA(1)="[DATA]"
SET YSDATA(2)=0
+8 SET YSN=1
+9 SET YSIEN=0
+10 FOR
SET YSIEN=$ORDER(^YSTX(604,"C",DFN,YSIEN))
if YSIEN'>0
QUIT
Begin DoDot:1
+11 SET YSN=YSN+1
+12 SET YSDATA(YSN)=YSIEN_U_$$FMTE^XLFDT($$GET1^DIQ(604,YSIEN_",",.05,"I"),"5ZD")_U_$$GET1^DIQ(604,YSIEN_",",.04,"E")_U_$$GET1^DIQ(604,YSIEN_",",.11,"E")_U_$$GET1^DIQ(604,YSIEN_",",.51,"E")_U_$$GET1^DIQ(604,YSIEN_",",.09,"E")
End DoDot:1
+13 QUIT
SIGNOK(YSDATA,YSIEN) ; all reqiured fields
+1 ;ysflag 1= ok 0= missing 2=SPECIAL
+2 NEW N1,YSASCLS,X,YSASFLD,YSF,YSASSPL,YSN,YSFLAG
+3 SET YSFLAG=1
+4 IF '$DATA(^YSTX(604,YSIEN,0))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="BAD IEN"
QUIT
+5 SET YSDATA(1)="[DATA]"
SET YSDATA(2)="1^OK TO SIGN"
+6 SET YSN=2
+7 SET YSASCLS=$$GET1^DIQ(604,YSIEN_",",.04,"I")
+8 SET YSASCLS=YSASCLS+3
+9 SET N1=0
FOR
SET N1=$ORDER(^YSTX(604.66,N1))
if N1'>0
QUIT
if ($PIECE(^YSTX(604.66,N1,0),U,8)&($PIECE(^YSTX(604.66,N1,0),U,YSASCLS)))
Begin DoDot:1
+10 SET YSASFLD=$PIECE(^YSTX(604.66,N1,0),U,3)
+11 DO TYPE
+12 ; S YSF=$S(YSASFLD>10.02&(YSASFLD<10.44):"I",$P(^DD(604,YSASFLD,0),U,2)?1"P".E:"",1:"I")
+13 SET YSF=$SELECT(YSASFLD>10.02&(YSASFLD<10.44):"I",YSTYPE=1:"",1:"I")
+14 SET X=$$GET1^DIQ(604,YSIEN,YSASFLD,YSF)
+15 if X=""
SET YSFLAG=0
SET YSN=YSN+1
SET YSDATA(YSN)=^YSTX(604,66,N1,0)
End DoDot:1
+16 SET X=$$GET1^DIQ(604,YSIEN,YSASFLD,.11)
+17 if X="X"!(X="N")
SET YSFLAG=2
+18 if YSFLAG=0
SET YSDATA(2)="0^MISSING REQUIRED FIELDS"
+19 if YSFLAG=2
SET YSDATA(2)="2^A G12 RECORD"
+20 QUIT
TYPE ;check field type
+1 ;O = NOT A POINTER 1 = POINTER
+2 NEW YSFLD,YSTYPE
+3 SET YSTYPE=0
+4 DO FIELD^DID(604,YSASFLD,"","TYPE","YSFLD")
+5 if YSFLD("TYPE")="POINTER"
SET YSTYPE=1
+6 QUIT
SIGN(YSDATA,YS) ; API for /es/
+1 NEW YSCODE,YSASINTV,YSASTRS,VALID
+2 SET YSCODE=$GET(YS("CODE"))
+3 IF YSCODE=""
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="NO SIG SENT"
QUIT
+4 SET YSIEN=$GET(YS("YSIEN"))
+5 IF YSIEN'>0
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="NO REC NUMBER"
QUIT
+6 IF '$DATA(^YSTX(604,YSIEN))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="NO REC FOUND"
QUIT
+7 SET VALID=$$VALIDATE($$DECRYP^XUSRB1(YSCODE))
+8 IF +VALID'>0
SET YSDATA(1)="[DATA]"
SET YSDATA(2)="0^Bad EScode, not signed"
QUIT
+9 ;INTERVERER
SET YSASINTV=$$GET1^DIQ(604,YSIEN_",",.09,"I")
+10 ;TRANSCRIBER
SET YSASTRS=$$GET1^DIQ(604,YSIEN_",",.14,"I")
+11 ;---> OUT
IF YSASINTV=DUZ
IF DUZ>0
Begin DoDot:1
+12 DO CR^YSASCR(YSIEN,YSASINTV,"")
+13 SET YSDATA(1)="[DATA]"
SET YSDATA(2)="1^ASI SIGNED"
End DoDot:1
QUIT
+14 ;---> OUT
IF YSASTRS=DUZ
IF DUZ>0
Begin DoDot:1
+15 DO CONV^YSASCR(YSIEN,YSASINTV)
+16 DO BUL^YSASBUL(YSIEN,YSASTRS,YSASINTV)
+17 SET YSDATA(1)="[DATA]"
SET YSDATA(2)="0^TRANSCRIBER SEND BULLETIN"
End DoDot:1
QUIT
+18 SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="BAD LOGIC"
+19 QUIT
VALIDATE(X) ; Validate /es/-code
+1 NEW YSY
SET YSY=0
+2 DO HASH^XUSHSHP
IF X]""
IF (X=$PIECE($GET(^VA(200,+DUZ,20)),U,4))
SET YSY=1
+3 QUIT YSY
