XHDAUTH.m

XHDAUTH ; SLC/JER - Authentication calls for HeVD ; 25 Jul 2003  9:42 AM

 ;;1.0;HEALTHEVET DESKTOP;;Jul 15, 2003

AUTHNTC(XHDY,ACCESS,VERIFY) ; authenticate user based on access/verify pair

 N XHD,UID,SPEC,COL,XHDI

 S (XHD,XHDI)=0

 S XHDY=$NA(^TMP("XHDCUID",$J)) K @XHDY

 D XMLHDR(XHDY,.XHDI)

 S UID=$$CHKAV^XUVERIFY(ACCESS_";"_VERIFY)

 I '+UID D

 . S XHDI=XHDI+1

 . S @XHDY@(XHDI)="<errorText>Invalid Access/Verify Code Pair</errorText>"

 E  D UIDTBL(XHDY,UID,.XHDI)

 D XMLFOOT(XHDY,.XHDI)

 Q

BYPASS(XHDY) ; get user demographics w/o security

 N XHD,UID,SPEC,COL,XHDI

 S (XHD,XHDI)=0,UID=$G(DUZ)

 S XHDY=$NA(^TMP("XHDCUID",$J)) K @XHDY

 D XMLHDR(XHDY,.XHDI)

 I '+UID D

 . S XHDI=XHDI+1

 . S @XHDY@(XHDI)="<errorText>Invalid Access/Verify Code Pair</errorText>"

 E  D UIDTBL(XHDY,UID,.XHDI)

 D XMLFOOT(XHDY,.XHDI)

 Q

XMLHDR(XHDY,XHDI) ; append header

 S XHDI=XHDI+1

 S @XHDY@(XHDI)="<result xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"" xsi:noNamespaceSchemaLocation=""AuthenticateSchema.xsd"">"

 Q

XMLFOOT(XHDY,XHDI)        ; append footer

 S XHDI=XHDI+1

 S @XHDY@(XHDI)="</result>"

 Q

UIDTBL(XHDY,UID,XHDI) ; userIdTable

 N SSN,NSDA,FNM,LNM,MI,TITLE

 S NSDA=+$G(^VA(200,UID,3.1))

 I NSDA D

 . N NSE

 . S NSE=$G(^VA(20,NSDA,1)),LNM=$P(NSE,U),FNM=$P(NSE,U,2),MI=$E($P(NSE,U,3))

 E  D

 . N NAME

 . S NAME=$$NAME^XUSER(UID)

 . S LNM=$$NAME^TIULS(NAME,"LAST"),FNM=$$NAME^TIULS(NAME,"FIRST"),MI=$$NAME^TIULS(NAME,"MI")

 S SSN=$E($P($G(^VA(200,UID,1)),U,9),6,10)

 S TITLE=$P($G(^VA(200,UID,20)),U,3)

 S XHDI=XHDI+1,@XHDY@(XHDI)="<userInfo>"

 D ADDELEM(XHDY,"uniqueId",UID,.XHDI)

 D ADDELEM(XHDY,"firstName",FNM,.XHDI)

 D ADDELEM(XHDY,"lastName",LNM,.XHDI)

 D ADDELEM(XHDY,"middleInitial",MI,.XHDI)

 D ADDELEM(XHDY,"title",TITLE,.XHDI)

 D ADDELEM(XHDY,"lastFourSSN",SSN,.XHDI)

 S XHDI=XHDI+1,@XHDY@(XHDI)="</userInfo>"

 Q

 ;

ADDELEM(XHDY,TAG,VAL,XHDI)        ; Insert an element with its value

 S XHDI=XHDI+1,@XHDY@(XHDI)="<"_TAG_$S(VAL']"":"/>",1:">"_$$ESCAPE^XHDLXM(VAL)_"</"_TAG_">")

 Q

BUILDROW(COL,RNM) ; Resolve fields for each row

 S COL(1)=$$ESCAPE^XHDLXM(RNM)

 Q

XHDAUTH   ; SLC/JER - Authentication calls for HeVD ; 25 Jul 2003  9:42 AM

 +1       ;;1.0;HEALTHEVET DESKTOP;;Jul 15, 2003

AUTHNTC(XHDY,ACCESS,VERIFY) ; authenticate user based on access/verify pair

 +1        NEW XHD,UID,SPEC,COL,XHDI

 +2        SET (XHD,XHDI)=0

 +3        SET XHDY=$NAME(^TMP("XHDCUID",$JOB))

           KILL @XHDY

 +4        DO XMLHDR(XHDY,.XHDI)

 +5        SET UID=$$CHKAV^XUVERIFY(ACCESS_";"_VERIFY)

 +6        IF '+UID

               Begin DoDot:1

 +7                SET XHDI=XHDI+1

 +8                SET @XHDY@(XHDI)="<errorText>Invalid Access/Verify Code Pair</errorText>"

               End DoDot:1

 +9       IF '$TEST

               DO UIDTBL(XHDY,UID,.XHDI)

 +10       DO XMLFOOT(XHDY,.XHDI)

 +11       QUIT 

BYPASS(XHDY) ; get user demographics w/o security

 +1        NEW XHD,UID,SPEC,COL,XHDI

 +2        SET (XHD,XHDI)=0

           SET UID=$GET(DUZ)

 +3        SET XHDY=$NAME(^TMP("XHDCUID",$JOB))

           KILL @XHDY

 +4        DO XMLHDR(XHDY,.XHDI)

 +5        IF '+UID

               Begin DoDot:1

 +6                SET XHDI=XHDI+1

 +7                SET @XHDY@(XHDI)="<errorText>Invalid Access/Verify Code Pair</errorText>"

               End DoDot:1

 +8       IF '$TEST

               DO UIDTBL(XHDY,UID,.XHDI)

 +9        DO XMLFOOT(XHDY,.XHDI)

 +10       QUIT 

XMLHDR(XHDY,XHDI) ; append header

 +1        SET XHDI=XHDI+1

 +2        SET @XHDY@(XHDI)="<result xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"" xsi:noNamespaceSchemaLocation=""AuthenticateSchema.xsd"">"

 +3        QUIT 

XMLFOOT(XHDY,XHDI) ; append footer

 +1        SET XHDI=XHDI+1

 +2        SET @XHDY@(XHDI)="</result>"

 +3        QUIT 

UIDTBL(XHDY,UID,XHDI) ; userIdTable

 +1        NEW SSN,NSDA,FNM,LNM,MI,TITLE

 +2        SET NSDA=+$GET(^VA(200,UID,3.1))

 +3        IF NSDA

               Begin DoDot:1

 +4                NEW NSE

 +5                SET NSE=$GET(^VA(20,NSDA,1))

                   SET LNM=$PIECE(NSE,U)

                   SET FNM=$PIECE(NSE,U,2)

                   SET MI=$EXTRACT($PIECE(NSE,U,3))

               End DoDot:1

 +6       IF '$TEST

               Begin DoDot:1

 +7                NEW NAME

 +8                SET NAME=$$NAME^XUSER(UID)

 +9                SET LNM=$$NAME^TIULS(NAME,"LAST")

                   SET FNM=$$NAME^TIULS(NAME,"FIRST")

                   SET MI=$$NAME^TIULS(NAME,"MI")

               End DoDot:1

 +10       SET SSN=$EXTRACT($PIECE($GET(^VA(200,UID,1)),U,9),6,10)

 +11       SET TITLE=$PIECE($GET(^VA(200,UID,20)),U,3)

 +12       SET XHDI=XHDI+1

           SET @XHDY@(XHDI)="<userInfo>"

 +13       DO ADDELEM(XHDY,"uniqueId",UID,.XHDI)

 +14       DO ADDELEM(XHDY,"firstName",FNM,.XHDI)

 +15       DO ADDELEM(XHDY,"lastName",LNM,.XHDI)

 +16       DO ADDELEM(XHDY,"middleInitial",MI,.XHDI)

 +17       DO ADDELEM(XHDY,"title",TITLE,.XHDI)

 +18       DO ADDELEM(XHDY,"lastFourSSN",SSN,.XHDI)

 +19       SET XHDI=XHDI+1

           SET @XHDY@(XHDI)="</userInfo>"

 +20       QUIT 

 +21      ;

ADDELEM(XHDY,TAG,VAL,XHDI) ; Insert an element with its value

 +1        SET XHDI=XHDI+1

           SET @XHDY@(XHDI)="<"_TAG_$SELECT(VAL']"":"/>",1:">"_$$ESCAPE^XHDLXM(VAL)_"</"_TAG_">")

 +2        QUIT 

BUILDROW(COL,RNM) ; Resolve fields for each row

 +1        SET COL(1)=$$ESCAPE^XHDLXM(RNM)

 +2        QUIT