INCRYP ;LD,DGH; 22 Apr 99 19:36; Encryption socket functions
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;COPYRIGHT 1991-2000 SAIC
;
Q
;
ENCRYPT(INARR,INV,DESKEY,INIP,INERR) ;
;INPUT:
; INARR = Message array to be encrypted.
; INV = Array in which the encrypted message will be returned.
; Pass by reference.
; DESKEY = DES encryption key. This parameter is only needed
; for the first string of a message.
; INIP = Array containing parameter (PBR). Key parameter is:
; INIP("EOL") = End of line. Pass by reference.
; INERR = Error message. Pass by reference.
;
; OUTPUT:
; 1 if successful, 0 if error
;
N STOP,START,END,INBUF,INMAX,INCRYPT,LINE,LINO,INSMIN,INVS,EOL,ENARR
N NEWNODE,ORGNODE,COUNT,ORGLEN,RC
I '$L($G(DESKEY)) S INERR="Missing DES key" Q 0
I $L($G(DESKEY))>8 S INERR="Invalid length of DES key" Q 0
I '$D(INARR) S INERR="No message array to be encrypted" Q 0
S START=1,INMAX=328,INBUF=""
S INVS=$P(^INRHSITE(1,0),U,12)
S EOL=$S($L($G(INIP("EOL"))):$C(INIP("EOL")),1:"")
S RC=$$CRYPON^INCRYPT(DESKEY)
S INSMIN=$S($P($G(^INRHSITE(1,0)),U,14):$P(^(0),U,14),1:2500)
S (STOP,END)=0,LINO=1
S ENARR=INARR,ORGLEN=$L(INARR)
F S ENARR=$Q(@ENARR) Q:'$L(ENARR)!STOP D
.S COUNT=$L(INARR,",")
.;Local array
.I COUNT=1 S NEWNODE=$E($G(ENARR),1,ORGLEN)
.;Global with node and IEN(s)
.I COUNT>1 S NEWNODE=$E($G(ENARR),1,ORGLEN-1)_")" D
.. I $E($G(ENARR),ORGLEN)'["," S STOP=1 Q
.S ORGNODE=$E($G(INARR),1,$L(INARR))
.; Matching the current node with the original node
.I NEWNODE'=ORGNODE S STOP=1 Q
. S LINE=$G(@ENARR)
. I $L(EOL) S LINE=LINE_EOL
. S X=$$PACK(LINE,INMAX,.INBUF)
. Q:'$L(X)
. I '$Q(@ENARR),'$L(INBUF) S END=1
. D ENCRYPT^INCRYPT(X,.INCRYPT,$L(X),START,END) S START=0
. D:'INVS MC^INHS
. S @INV@(LINO)=$G(INCRYPT),LINO=LINO+1
. I $L(INBUF)>INMAX D
.. N LINE1,INCRYPT1
.. S LINE1=INBUF,INBUF=""
.. S X1=$$PACK(LINE1,INMAX,.INBUF)
.. I '$Q(@ENARR),'$L(INBUF) S END=1
.. D ENCRYPT^INCRYPT(X1,.INCRYPT1,$L(X1),START,END)
.. D:'INVS MC^INHS
.. S @INV@(LINO)=$G(INCRYPT1),LINO=LINO+1
S END=1 D
. Q:'$L(INBUF)
. D ENCRYPT^INCRYPT(INBUF,.INCRYPT,$L(INBUF),START,END)
. D:'INVS MC^INHS
. S @INV@(LINO)=$G(INCRYPT)
S RC=$$CRYPOFF^INCRYPT()
Q 1
;
DECRYPT(DECARR,INV,DESKEY,INERR) ;
; INPUT:
; DECARR = Name of the array containing encrypted message strings
; to be decrypted.
; INV = Name of the array which the API will use to return the
; decrypted message string. Pass by reference.
; If local symbol space is low, the API will return a global array.
; DESKEY = DES encryption key. This parameter is only needed
; for the first string to be decrypted.
; INERR = Error message. Pass by reference.
;
; OUTPUT:
; 1 if successful, 0 if error
;
N I,DECRYPT,INVS,INSMIN,START,END,LINE,LINO,RC
I '$D(DECARR) S INERR="No message array to be encrypted" Q 0
I '$L($G(DESKEY)) S INERR="Missing DES key" Q 0
I $L($G(DESKEY))>8 S INERR="Invalid length of DES key" Q 0
S INVS=$P(^INRHSITE(1,0),U,12)
S START=1
S RC=$$CRYPON^INCRYPT(DESKEY)
S INSMIN=$S($P($G(^INRHSITE(1,0)),U,14):$P(^(0),U,14),1:2500)
S (I,END)=0,LINO=1
F S I=$O(@DECARR@(I)) Q:'+I D
. S LINE=$G(@DECARR@(I))
. I '$O(@DECARR@(I)) S END=1
. D DECRYPT^INCRYPT(LINE,.DECRYPT,$L(LINE),START,END) S START=0
. D:'INVS MC^INHS
. S @INV@(LINO)=$G(DECRYPT),LINO=LINO+1
S RC=$$CRYPOFF^INCRYPT()
Q 1
;
PACK(INLIN,INMAX,INBUF) ;pack segments into packets
;INPUT
; INLIN = line to pack
; INMAX = maximum string length
; INBUF = Overflow buffer (PBR)
;RETURN
; Return value will be a string with length of max string if
; INLIN has been exceeded. Null if it has not.
; INBUF will have the overflow from max string length. Calling
; routine should keep returning INBUF without change.
;
N BL,INLINE,L
S INBUF=$G(INBUF),BL=$L(INBUF)
I BL+$L(INLIN)'>INMAX S INBUF=INBUF_INLIN
E S L=(INMAX-BL),INBUF=INBUF_$E(INLIN,1,L),INLIN=$E(INLIN,L+1,$L(INLIN)) S INLINE=INBUF,INBUF=INLIN
Q $G(INLINE)
INCRYP ;LD,DGH; 22 Apr 99 19:36; Encryption socket functions
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;COPYRIGHT 1991-2000 SAIC
+3 ;
+4 QUIT
+5 ;
ENCRYPT(INARR,INV,DESKEY,INIP,INERR) ;
+1 ;INPUT:
+2 ; INARR = Message array to be encrypted.
+3 ; INV = Array in which the encrypted message will be returned.
+4 ; Pass by reference.
+5 ; DESKEY = DES encryption key. This parameter is only needed
+6 ; for the first string of a message.
+7 ; INIP = Array containing parameter (PBR). Key parameter is:
+8 ; INIP("EOL") = End of line. Pass by reference.
+9 ; INERR = Error message. Pass by reference.
+10 ;
+11 ; OUTPUT:
+12 ; 1 if successful, 0 if error
+13 ;
+14 NEW STOP,START,END,INBUF,INMAX,INCRYPT,LINE,LINO,INSMIN,INVS,EOL,ENARR
+15 NEW NEWNODE,ORGNODE,COUNT,ORGLEN,RC
+16 IF '$LENGTH($GET(DESKEY))
SET INERR="Missing DES key"
QUIT 0
+17 IF $LENGTH($GET(DESKEY))>8
SET INERR="Invalid length of DES key"
QUIT 0
+18 IF '$DATA(INARR)
SET INERR="No message array to be encrypted"
QUIT 0
+19 SET START=1
SET INMAX=328
SET INBUF=""
+20 SET INVS=$PIECE(^INRHSITE(1,0),U,12)
+21 SET EOL=$SELECT($LENGTH($GET(INIP("EOL"))):$CHAR(INIP("EOL")),1:"")
+22 SET RC=$$CRYPON^INCRYPT(DESKEY)
+23 SET INSMIN=$SELECT($PIECE($GET(^INRHSITE(1,0)),U,14):$PIECE(^(0),U,14),1:2500)
+24 SET (STOP,END)=0
SET LINO=1
+25 SET ENARR=INARR
SET ORGLEN=$LENGTH(INARR)
+26 FOR
SET ENARR=$QUERY(@ENARR)
IF '$LENGTH(ENARR)!STOP
QUIT
Begin DoDot:1
+27 SET COUNT=$LENGTH(INARR,",")
+28 ;Local array
+29 IF COUNT=1
SET NEWNODE=$EXTRACT($GET(ENARR),1,ORGLEN)
+30 ;Global with node and IEN(s)
+31 IF COUNT>1
SET NEWNODE=$EXTRACT($GET(ENARR),1,ORGLEN-1)_")"
Begin DoDot:2
+32 IF $EXTRACT($GET(ENARR),ORGLEN)'[","
SET STOP=1
QUIT
End DoDot:2
+33 SET ORGNODE=$EXTRACT($GET(INARR),1,$LENGTH(INARR))
+34 ; Matching the current node with the original node
+35 IF NEWNODE'=ORGNODE
SET STOP=1
QUIT
+36 SET LINE=$GET(@ENARR)
+37 IF $LENGTH(EOL)
SET LINE=LINE_EOL
+38 SET X=$$PACK(LINE,INMAX,.INBUF)
+39 IF '$LENGTH(X)
QUIT
+40 IF '$QUERY(@ENARR)
IF '$LENGTH(INBUF)
SET END=1
+41 DO ENCRYPT^INCRYPT(X,.INCRYPT,$LENGTH(X),START,END)
SET START=0
+42 IF 'INVS
DO MC^INHS
+43 SET @INV@(LINO)=$GET(INCRYPT)
SET LINO=LINO+1
+44 IF $LENGTH(INBUF)>INMAX
Begin DoDot:2
+45 NEW LINE1,INCRYPT1
+46 SET LINE1=INBUF
SET INBUF=""
+47 SET X1=$$PACK(LINE1,INMAX,.INBUF)
+48 IF '$QUERY(@ENARR)
IF '$LENGTH(INBUF)
SET END=1
+49 DO ENCRYPT^INCRYPT(X1,.INCRYPT1,$LENGTH(X1),START,END)
+50 IF 'INVS
DO MC^INHS
+51 SET @INV@(LINO)=$GET(INCRYPT1)
SET LINO=LINO+1
End DoDot:2
End DoDot:1
+52 SET END=1
Begin DoDot:1
+53 IF '$LENGTH(INBUF)
QUIT
+54 DO ENCRYPT^INCRYPT(INBUF,.INCRYPT,$LENGTH(INBUF),START,END)
+55 IF 'INVS
DO MC^INHS
+56 SET @INV@(LINO)=$GET(INCRYPT)
End DoDot:1
+57 SET RC=$$CRYPOFF^INCRYPT()
+58 QUIT 1
+59 ;
DECRYPT(DECARR,INV,DESKEY,INERR) ;
+1 ; INPUT:
+2 ; DECARR = Name of the array containing encrypted message strings
+3 ; to be decrypted.
+4 ; INV = Name of the array which the API will use to return the
+5 ; decrypted message string. Pass by reference.
+6 ; If local symbol space is low, the API will return a global array.
+7 ; DESKEY = DES encryption key. This parameter is only needed
+8 ; for the first string to be decrypted.
+9 ; INERR = Error message. Pass by reference.
+10 ;
+11 ; OUTPUT:
+12 ; 1 if successful, 0 if error
+13 ;
+14 NEW I,DECRYPT,INVS,INSMIN,START,END,LINE,LINO,RC
+15 IF '$DATA(DECARR)
SET INERR="No message array to be encrypted"
QUIT 0
+16 IF '$LENGTH($GET(DESKEY))
SET INERR="Missing DES key"
QUIT 0
+17 IF $LENGTH($GET(DESKEY))>8
SET INERR="Invalid length of DES key"
QUIT 0
+18 SET INVS=$PIECE(^INRHSITE(1,0),U,12)
+19 SET START=1
+20 SET RC=$$CRYPON^INCRYPT(DESKEY)
+21 SET INSMIN=$SELECT($PIECE($GET(^INRHSITE(1,0)),U,14):$PIECE(^(0),U,14),1:2500)
+22 SET (I,END)=0
SET LINO=1
+23 FOR
SET I=$ORDER(@DECARR@(I))
IF '+I
QUIT
Begin DoDot:1
+24 SET LINE=$GET(@DECARR@(I))
+25 IF '$ORDER(@DECARR@(I))
SET END=1
+26 DO DECRYPT^INCRYPT(LINE,.DECRYPT,$LENGTH(LINE),START,END)
SET START=0
+27 IF 'INVS
DO MC^INHS
+28 SET @INV@(LINO)=$GET(DECRYPT)
SET LINO=LINO+1
End DoDot:1
+29 SET RC=$$CRYPOFF^INCRYPT()
+30 QUIT 1
+31 ;
PACK(INLIN,INMAX,INBUF) ;pack segments into packets
+1 ;INPUT
+2 ; INLIN = line to pack
+3 ; INMAX = maximum string length
+4 ; INBUF = Overflow buffer (PBR)
+5 ;RETURN
+6 ; Return value will be a string with length of max string if
+7 ; INLIN has been exceeded. Null if it has not.
+8 ; INBUF will have the overflow from max string length. Calling
+9 ; routine should keep returning INBUF without change.
+10 ;
+11 NEW BL,INLINE,L
+12 SET INBUF=$GET(INBUF)
SET BL=$LENGTH(INBUF)
+13 IF BL+$LENGTH(INLIN)'>INMAX
SET INBUF=INBUF_INLIN
+14 IF '$TEST
SET L=(INMAX-BL)
SET INBUF=INBUF_$EXTRACT(INLIN,1,L)
SET INLIN=$EXTRACT(INLIN,L+1,$LENGTH(INLIN))
SET INLINE=INBUF
SET INBUF=INLIN
+15 QUIT $GET(INLINE)
