- INCRYPQD ;LD,DGH; 22 Apr 99 19:18; 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)
- INCRYPQD ;LD,DGH; 22 Apr 99 19:18; 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)
