source: FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTAPI8.m@ 1800

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