XWBBRK2.m

XWBBRK2 ;ISC-SF/EG - DHCP BROKER PROTOYPE - [ 04/02/2003   8:48 AM ]

 ;;1.1;RPC BROKER;**5,1001,1018**;JUN 7, 2013;Build 7

CAPI(XWBY,TAG,NAM,PAR) ;make API call

 N R,T,DX,DY

 IF XWB(1,"FLAG")=2 D

 . S PAR=$P(PAR,XWB("FRM"))_XWB("TO")_$P(PAR,XWB("FRM"),2)

 S R=$S(PAR'=+PAR&(PAR=""):TAG_"^"_NAM_"(.XWBY)",1:TAG_"^"_NAM_"(.XWBY,"_PAR_")")

 D:$D(XRTL) T0^%ZOSV ;start RTL

 U XWBNULL

 ;

 ;start RUM for RPC

 I $G(XWB(2,"CAPI"))]"" D LOGRSRC^%ZOSV(XWB(2,"CAPI"),2,1)

 ;

 D @R

 ;

 N X,STS S X="BUSARPC",STS="" X ^%ZOSF("TEST") S:$T STS=$$XWB^BUSARPC(.XWB) K X,STS  ;IHS/OIT/FBD - 4/17/2013 - BXWB*1.1 / XWB*1.1*1018 - ADDED LINE - ENABLE BUSA AUDITING (MU2 REQUIREMENT)

 ;

 ;restart RUM for handler

 D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,1)

 ;

 S:$D(XRT0) XRTN=XWB(2,"NAME") D:$D(XRT0) T1^%ZOSV ;stop RTL

 ;once call is completed, write buffer should be empty, make it so!

 U XWBNULL S DX=0,DY=0 X ^%ZOSF("XY")

 U XWBTDEV

 Q

 ;

BHDR(WKID,WINH,PRCH,WISH) ;Build a protocol header

 N S,L

 S S=""

 S S=WKID_";"_WINH_";"_PRCH_";"_WISH_";"

 S L=$L(S)

 S S=$E("000"_L,$L(L)+1,$L(L)+3)_S

 Q S

 ;

BARY(A,R,V) ;add array elements+values to storage array

 IF A'["XWBS" Q "-1^ARRAY NAME MUST BE XWBS"

 S @A@(R)=V

 Q 0

 ;

BLDB(P) ;Build formatted string

 N L

 S L=$L(P)

 Q $E("000"_L,$L(L)+1,$L(L)+3)_P

 ;

BLDA(N,P) ;Build API string

 ;M Extrinsic Function

 ;Inputs

 ;N        API name

 ;P        Comma delimited parameter string

 ;Outputs

 ;String   API string if successful, "-1^Text" if error

 ;

 N I,F,L,T,U,T1,T2

 IF '+$D(N) Q "-1^Required input reference is NULL"

 S U="^"

 S (F,T,Y)=0

 IF '$D(P) S P=""

 IF P'="" D

 . S L=$L(P)-$L($TR(P,$C(44)))+1

 . IF L=0 S L=1

 . F I=1:1:L D  Q:T

 . . S T1=$P(P,",",I)

 . . S T2=$E(T1,1,1)="."

 . . IF T1=+T1 Q

 . . IF $E(T1,1,1)="^" S F=2,T=1 Q

 . . ;IF $E(T1,1,5)="$NA(^" S F=2,T=1 Q

 . . IF T2&($E(T1,2,$L(T1))?.ANP) S F=1,T=1 Q

 ;IF P?.ANP1"."1A.ANP S F=1

 S P=$$BLDB(P)

 S L=$L(P)+$L(P)-3

 S P=F_N_U_P

 S L=$L(P)

 Q $E("000"_L,$L(L)+1,$L(L)+3)_P

 ;

BLDS(R) ;Build a parameter string from an array

 N L,T,Y

 S Y=""

 F  D  Q:R=""

 . S R=$Q(@R)

 . IF R="" Q

 . S L=$L(R)+$L(@R)+1

 . S T=@R

 . S T=$TR(T,$C(44),$C(23))

 . S Y=Y_$E("000"_L,$L(L)+1,$L(L)+3)_R_"="_T

 Q Y_"000"

 ;

BLDU(R) ;Build a parameter string from a scalar

 N DONE,L,N,N1,P1

 IF R=+R Q R

 S N=$F(R,$C(34))

 IF N=0 Q $C(34)_R_$C(34)

 S P1=$E(R,1,N-2)

 S (L,DONE)=0

 F  D  Q:DONE

 . S N1=$F(R,$C(34),N)

 . IF N1=0 S L=$L(R)+2,N1=L

 . S P1=P1_$C(34,34)_$E(R,N,N1-2)

 . IF N1=L S DONE=1,P1=$C(34)_P1_$C(34) Q

 . S N=N1

 Q $TR(P1,$C(44),$C(23))

 ;

BLDG(R) ;build a parameter string from a global reference

 N I,L,L1,M,T,T1,T2,Y

 K ^TMP("XWB",$J)

 IF '$D(R) Q "-1^Reference does not exist"

 S Y=$NA(^TMP("XWB",$J,$P($H,",",2)))

 S I=0

 S M=512

 S T1=$P(R,")")

 S L1=$L($P(R,"("))

 F  D  Q:R=""

 . S R=$Q(@R)

 . S T2=$F(R,"(")

 . IF R=""!(R'[T1) Q

 . S L=$L(R)+$L(@R)-L1

 . S T=@R

 . S T=$TR(T,$C(44),$C(23))

 . S @Y@(I)=$E("000"_L,$L(L)+1,$L(L)+3)_"^("_$E(R,T2,M)_"="_$$BLDU(T)

 . S I=I+1

 S @Y@(I)="000"

 S Y=$TR(Y,$C(44),$C(23))

 Q Y

 ;

OARY() ;create storage array

 N A,DONE,I

 S (DONE,I)=0

 F I=1:1 D  Q:DONE

 . S A="XWBS"_I

 . K @A ;temp fix for single array

 . IF '$D(@A) S DONE=1

 ;S Y("XWBS")=A

 S @A="" ;set naked

 Q A

 ;

CREF(R,P) ;Convert array contained in P to reference A

 N I,X,DONE,F1,S

 S DONE=0

 S S=""

 F I=1:1  D  Q:DONE

 . IF $P(P,",",I)="" S DONE=1 Q

 . S X(I)=$P(P,",",I)

 . IF X(I)?1"."1A.E D

 . . S F1=$F(X(I),".")

 . . S X(I)="."_R

 . S S=S_X(I)_","

 Q $E(S,1,$L(S)-1)

 ;

GETP(P) ;returns various parameters out of the Protocol string

 N M,T,XWB

 S M=512

 S T=$$PRSP^XWBBRK(P)

 IF '+T D

 . S T=$$PRSM^XWBBRK(XWB(0,"MESG"))

 . IF '+T S T=XWB(0,"WKID")_";"_XWB(0,"WINH")_";"_XWB(0,"PRCH")_";"_XWB(0,"WISH")_";"_$P(XWB(1,"TEXT"),"^")

 Q T

 ;

CALLM(X,P,DEBUG) ;make call using Message string

 N ERR,S

 S X="",ERR=0

 S ERR=$$PRSM^XWBBRK(P)

 IF '+ERR S ERR=$$PRSA^XWBBRK(XWB(1,"TEXT"))

 IF '+ERR S S=$$PRSB^XWBBRK(XWB(2,"PARM"))

 IF (+S=0)!(+S>0) D

 . D CAPI(.X,XWB(2,"RTAG"),XWB(2,"RNAM"),S)

 IF 'DEBUG K XWB

 K @(X("XWBS")),X("XWBS")

 Q

 ;

CALLA(X,P,DEBUG) ;make call using API string

 N ERR,S

 S X="",ERR=0

 S ERR=$$PRSA^XWBBRK(P)

 IF '+ERR S S=$$PRSB^XWBBRK(XWB(2,"PARM"))

 IF (+S=0)!(+S>0) D

 . D CAPI(.X,XWB(2,"RTAG"),XWB(2,"RNAM"),S)

 IF 'DEBUG K XWB

 K @(X("XWBS")),X("XWBS")

 Q

 ;

TRANSPRT() ;Determine the Transport Method

 ;DDP is local :=0

 ;TCP/IP is remote :=1

 ;Serial/RS-232 is remote :=2

 Q 1

 ;Q 0 ;Do DDP for Now

XWBBRK2   ;ISC-SF/EG - DHCP BROKER PROTOYPE - [ 04/02/2003   8:48 AM ]

 +1       ;;1.1;RPC BROKER;**5,1001,1018**;JUN 7, 2013;Build 7

CAPI(XWBY,TAG,NAM,PAR) ;make API call

 +1        NEW R,T,DX,DY

 +2        IF XWB(1,"FLAG")=2

               Begin DoDot:1

 +3                SET PAR=$PIECE(PAR,XWB("FRM"))_XWB("TO")_$PIECE(PAR,XWB("FRM"),2)

               End DoDot:1

 +4        SET R=$SELECT(PAR'=+PAR&(PAR=""):TAG_"^"_NAM_"(.XWBY)",1:TAG_"^"_NAM_"(.XWBY,"_PAR_")")

 +5       ;start RTL

           IF $DATA(XRTL)

               DO T0^%ZOSV

 +6        USE XWBNULL

 +7       ;

 +8       ;start RUM for RPC

 +9        IF $GET(XWB(2,"CAPI"))]""

               DO LOGRSRC^%ZOSV(XWB(2,"CAPI"),2,1)

 +10      ;

 +11       DO @R

 +12      ;

 +13      ;IHS/OIT/FBD - 4/17/2013 - BXWB*1.1 / XWB*1.1*1018 - ADDED LINE - ENABLE BUSA AUDITING (MU2 REQUIREMENT)

           NEW X,STS

           SET X="BUSARPC"

           SET STS=""

           XECUTE ^%ZOSF("TEST")

           IF $TEST

               SET STS=$$XWB^BUSARPC(.XWB)

           KILL X,STS

 +14      ;

 +15      ;restart RUM for handler

 +16       DO LOGRSRC^%ZOSV("$BROKER HANDLER$",2,1)

 +17      ;

 +18      ;stop RTL

           IF $DATA(XRT0)

               SET XRTN=XWB(2,"NAME")

           IF $DATA(XRT0)

               DO T1^%ZOSV

 +19      ;once call is completed, write buffer should be empty, make it so!

 +20       USE XWBNULL

           SET DX=0

           SET DY=0

           XECUTE ^%ZOSF("XY")

 +21       USE XWBTDEV

 +22       QUIT 

 +23      ;

BHDR(WKID,WINH,PRCH,WISH) ;Build a protocol header

 +1        NEW S,L

 +2        SET S=""

 +3        SET S=WKID_";"_WINH_";"_PRCH_";"_WISH_";"

 +4        SET L=$LENGTH(S)

 +5        SET S=$EXTRACT("000"_L,$LENGTH(L)+1,$LENGTH(L)+3)_S

 +6        QUIT S

 +7       ;

BARY(A,R,V) ;add array elements+values to storage array

 +1        IF A'["XWBS"

               QUIT "-1^ARRAY NAME MUST BE XWBS"

 +2        SET @A@(R)=V

 +3        QUIT 0

 +4       ;

BLDB(P)   ;Build formatted string

 +1        NEW L

 +2        SET L=$LENGTH(P)

 +3        QUIT $EXTRACT("000"_L,$LENGTH(L)+1,$LENGTH(L)+3)_P

 +4       ;

BLDA(N,P) ;Build API string

 +1       ;M Extrinsic Function

 +2       ;Inputs

 +3       ;N        API name

 +4       ;P        Comma delimited parameter string

 +5       ;Outputs

 +6       ;String   API string if successful, "-1^Text" if error

 +7       ;

 +8        NEW I,F,L,T,U,T1,T2

 +9        IF '+$DATA(N)

               QUIT "-1^Required input reference is NULL"

 +10       SET U="^"

 +11       SET (F,T,Y)=0

 +12       IF '$DATA(P)

               SET P=""

 +13       IF P'=""

               Begin DoDot:1

 +14               SET L=$LENGTH(P)-$LENGTH($TRANSLATE(P,$CHAR(44)))+1

 +15               IF L=0

                       SET L=1

 +16               FOR I=1:1:L

                       Begin DoDot:2

 +17                       SET T1=$PIECE(P,",",I)

 +18                       SET T2=$EXTRACT(T1,1,1)="."

 +19                       IF T1=+T1

                               QUIT 

 +20                       IF $EXTRACT(T1,1,1)="^"

                               SET F=2

                               SET T=1

                               QUIT 

 +21      ;IF $E(T1,1,5)="$NA(^" S F=2,T=1 Q

 +22                       IF T2&($EXTRACT(T1,2,$LENGTH(T1))?.ANP)

                               SET F=1

                               SET T=1

                               QUIT 

                       End DoDot:2

                       IF T

                           QUIT 

               End DoDot:1

 +23      ;IF P?.ANP1"."1A.ANP S F=1

 +24       SET P=$$BLDB(P)

 +25       SET L=$LENGTH(P)+$LENGTH(P)-3

 +26       SET P=F_N_U_P

 +27       SET L=$LENGTH(P)

 +28       QUIT $EXTRACT("000"_L,$LENGTH(L)+1,$LENGTH(L)+3)_P

 +29      ;

BLDS(R)   ;Build a parameter string from an array

 +1        NEW L,T,Y

 +2        SET Y=""

 +3        FOR 

               Begin DoDot:1

 +4                SET R=$QUERY(@R)

 +5                IF R=""

                       QUIT 

 +6                SET L=$LENGTH(R)+$LENGTH(@R)+1

 +7                SET T=@R

 +8                SET T=$TRANSLATE(T,$CHAR(44),$CHAR(23))

 +9                SET Y=Y_$EXTRACT("000"_L,$LENGTH(L)+1,$LENGTH(L)+3)_R_"="_T

               End DoDot:1

               IF R=""

                   QUIT 

 +10       QUIT Y_"000"

 +11      ;

BLDU(R)   ;Build a parameter string from a scalar

 +1        NEW DONE,L,N,N1,P1

 +2        IF R=+R

               QUIT R

 +3        SET N=$FIND(R,$CHAR(34))

 +4        IF N=0

               QUIT $CHAR(34)_R_$CHAR(34)

 +5        SET P1=$EXTRACT(R,1,N-2)

 +6        SET (L,DONE)=0

 +7        FOR 

               Begin DoDot:1

 +8                SET N1=$FIND(R,$CHAR(34),N)

 +9                IF N1=0

                       SET L=$LENGTH(R)+2

                       SET N1=L

 +10               SET P1=P1_$CHAR(34,34)_$EXTRACT(R,N,N1-2)

 +11               IF N1=L

                       SET DONE=1

                       SET P1=$CHAR(34)_P1_$CHAR(34)

                       QUIT 

 +12               SET N=N1

               End DoDot:1

               IF DONE

                   QUIT 

 +13       QUIT $TRANSLATE(P1,$CHAR(44),$CHAR(23))

 +14      ;

BLDG(R)   ;build a parameter string from a global reference

 +1        NEW I,L,L1,M,T,T1,T2,Y

 +2        KILL ^TMP("XWB",$JOB)

 +3        IF '$DATA(R)

               QUIT "-1^Reference does not exist"

 +4        SET Y=$NAME(^TMP("XWB",$JOB,$PIECE($HOROLOG,",",2)))

 +5        SET I=0

 +6        SET M=512

 +7        SET T1=$PIECE(R,")")

 +8        SET L1=$LENGTH($PIECE(R,"("))

 +9        FOR 

               Begin DoDot:1

 +10               SET R=$QUERY(@R)

 +11               SET T2=$FIND(R,"(")

 +12               IF R=""!(R'[T1)

                       QUIT 

 +13               SET L=$LENGTH(R)+$LENGTH(@R)-L1

 +14               SET T=@R

 +15               SET T=$TRANSLATE(T,$CHAR(44),$CHAR(23))

 +16               SET @Y@(I)=$EXTRACT("000"_L,$LENGTH(L)+1,$LENGTH(L)+3)_"^("_$EXTRACT(R,T2,M)_"="_$$BLDU(T)

 +17               SET I=I+1

               End DoDot:1

               IF R=""

                   QUIT 

 +18       SET @Y@(I)="000"

 +19       SET Y=$TRANSLATE(Y,$CHAR(44),$CHAR(23))

 +20       QUIT Y

 +21      ;

OARY()    ;create storage array

 +1        NEW A,DONE,I

 +2        SET (DONE,I)=0

 +3        FOR I=1:1

               Begin DoDot:1

 +4                SET A="XWBS"_I

 +5       ;temp fix for single array

                   KILL @A

 +6                IF '$DATA(@A)

                       SET DONE=1

               End DoDot:1

               IF DONE

                   QUIT 

 +7       ;S Y("XWBS")=A

 +8       ;set naked

           SET @A=""

 +9        QUIT A

 +10      ;

CREF(R,P) ;Convert array contained in P to reference A

 +1        NEW I,X,DONE,F1,S

 +2        SET DONE=0

 +3        SET S=""

 +4        FOR I=1:1

               Begin DoDot:1

 +5                IF $PIECE(P,",",I)=""

                       SET DONE=1

                       QUIT 

 +6                SET X(I)=$PIECE(P,",",I)

 +7                IF X(I)?1"."1A.E

                       Begin DoDot:2

 +8                        SET F1=$FIND(X(I),".")

 +9                        SET X(I)="."_R

                       End DoDot:2

 +10               SET S=S_X(I)_","

               End DoDot:1

               IF DONE

                   QUIT 

 +11       QUIT $EXTRACT(S,1,$LENGTH(S)-1)

 +12      ;

GETP(P)   ;returns various parameters out of the Protocol string

 +1        NEW M,T,XWB

 +2        SET M=512

 +3        SET T=$$PRSP^XWBBRK(P)

 +4        IF '+T

               Begin DoDot:1

 +5                SET T=$$PRSM^XWBBRK(XWB(0,"MESG"))

 +6                IF '+T

                       SET T=XWB(0,"WKID")_";"_XWB(0,"WINH")_";"_XWB(0,"PRCH")_";"_XWB(0,"WISH")_";"_$PIECE(XWB(1,"TEXT"),"^")

               End DoDot:1

 +7        QUIT T

 +8       ;

CALLM(X,P,DEBUG) ;make call using Message string

 +1        NEW ERR,S

 +2        SET X=""

           SET ERR=0

 +3        SET ERR=$$PRSM^XWBBRK(P)

 +4        IF '+ERR

               SET ERR=$$PRSA^XWBBRK(XWB(1,"TEXT"))

 +5        IF '+ERR

               SET S=$$PRSB^XWBBRK(XWB(2,"PARM"))

 +6        IF (+S=0)!(+S>0)

               Begin DoDot:1

 +7                DO CAPI(.X,XWB(2,"RTAG"),XWB(2,"RNAM"),S)

               End DoDot:1

 +8        IF 'DEBUG

               KILL XWB

 +9        KILL @(X("XWBS")),X("XWBS")

 +10       QUIT 

 +11      ;

CALLA(X,P,DEBUG) ;make call using API string

 +1        NEW ERR,S

 +2        SET X=""

           SET ERR=0

 +3        SET ERR=$$PRSA^XWBBRK(P)

 +4        IF '+ERR

               SET S=$$PRSB^XWBBRK(XWB(2,"PARM"))

 +5        IF (+S=0)!(+S>0)

               Begin DoDot:1

 +6                DO CAPI(.X,XWB(2,"RTAG"),XWB(2,"RNAM"),S)

               End DoDot:1

 +7        IF 'DEBUG

               KILL XWB

 +8        KILL @(X("XWBS")),X("XWBS")

 +9        QUIT 

 +10      ;

TRANSPRT() ;Determine the Transport Method

 +1       ;DDP is local :=0

 +2       ;TCP/IP is remote :=1

 +3       ;Serial/RS-232 is remote :=2

 +4        QUIT 1

 +5       ;Q 0 ;Do DDP for Now