- 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 Jan 18, 2025@03:18:01 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