- HDISDSR1 ;BPFO/DTG - HDI MAILMAN SERVER COLLECT SDO DATA; Apr 07, 2018@12:42
- ;;1.0;HEALTH DATA & INFORMATICS;**22**;Feb 22, 2005;Build 26
- ;
- ;
- INIT ; initialize vars and file
- ;
- ; Uses ICR 5812 to read file 4.3 field 8.3
- ;
- K @HDISV
- S HDITXT=0,HDICRLF=$C(13,10),HDITAB=$C(9),HDIJB=$J,U="^"
- S HDISTR=""
- S HDISITE=$$SITE^VASITE,HDISTN=$P(HDISITE,"^",2),HDIST=$P(HDISITE,"^",3)
- I HDIST="" S HDIST="???"
- ;
- S HDISUB=$$UP^XLFSTR(XQSUB)
- ;get max lines and make character count
- N A,B S A=$$GET1^DIQ(4.3,"1,",8.3,"I") S B=$S((+A=0):5469,(A>15000):15000,1:A)
- S HDIMAX=((B*250)-((B*250)*.3))\1
- ;
- Q
- ;
- MAILSEND(HDISUBJ) ; Send extract back to requestor.
- ;
- N HDINSTR,HDITASK,HDITO,XMERR,XMZ,A
- ;
- ;ZEXCEPT: XQSND
- ;
- ;S 1=1
- S HDITO(XQSND)=""
- S HDINSTR("ADDR FLAGS")="R"
- S HDINSTR("FROM")="HDI_SDO_CODES"
- S HDISUBJ=$E(HDISUBJ,1,65)
- D SENDMSG^XMXAPI(.5,HDISUBJ,"^TMP($J,""HDIDATA"")",.HDITO,.HDINSTR,.HDITASK)
- S A=$G(^DTGHD("A",0)),A=A+1,^DTGHD("A",0)=A,^DTGHD("A",A)=HDITASK
- Q
- ;
- ENCODE(HDISTR) ; Encode a string, keep remainder for next line
- ; Call with ORSTR by reference, Remainder returned in LRSTR
- ;
- S HDIQUIT=0,HDILEN=$L(HDISTR)
- F D Q:HDIQUIT
- . I $L(HDISTR)<45 S HDIQUIT=1 Q
- . S HDIX=$E(HDISTR,1,45),LT=LT+$L(HDIX)
- . S HDINODE=HDINODE+1,@HDISV@(HDINODE)=$$UUEN(HDIX)
- . S HDISTR=$E(HDISTR,46,HDILEN)
- Q
- ;
- UUEN(STR) ; Uuencode string passed in.
- N J,K,LEN,HDII,HDIX,S,TMP,X,Y
- S TMP="",LEN=$L(STR)
- F HDII=1:3:LEN D
- . S HDIX=$E(STR,HDII,HDII+2)
- . I $L(HDIX)<3 S HDIX=HDIX_$E(" ",1,3-$L(HDIX))
- . S S=$A(HDIX,1)*256+$A(HDIX,2)*256+$A(HDIX,3),Y=""
- . F K=0:1:23 S Y=(S\(2**K)#2)_Y
- . F K=1:6:24 D
- . . S J=$$DEC^XLFUTL($E(Y,K,K+5),2)
- . . S TMP=TMP_$C(J+32)
- S TMP=$C(LEN+32)_TMP
- Q TMP
- ;
- UUBEGFN(HDFILENM) ; Construct uuencode "begin" coding
- ; Call with HDFILENM = name of uuencoded file attachment
- ;
- ; Returns HDIX = string with "begin..."_file name
- ;
- N HDIX
- S HDIX="begin 644 "_HDFILENM
- Q HDIX
- ;
- ;
- SETDATA ; Set data into report structure
- S HDINODE=$O(^TMP($J,"HDIDATA",""),-1)
- I HDITXT S HDINODE=HDINODE+1,@HDISV@(HDINODE)=HDISTR,HDISTR="" Q
- I 'HDITXT D ENCODE(.HDISTR)
- Q
- ;
- CLEAN ; clean up
- D CLEAN^HDISDSR
- D ^%ZISC
- Q
- ;
- DISER ; display return error type
- I RERROR=0 Q
- N MSG,A,I,B,J,RR
- ; remove multi's of repeating error #'s
- F I=1:1 S A=$P(RERROR,",",I) Q:A="" S B(A)=""
- ;
- S J=$O(@HDISV@(""),-1),J=J+1
- S @HDISV@(J)=$$UUBEGFN(HDIFER)
- S HDISTR="ERROR ITEMS FROM HDI SDO LOOKUP"_HDICRLF
- D SETDATA
- S A=0 F S A=$O(B(A)) Q:'A S HDISTR=HDISTR_A_") "_$P($T(DISTXT+A),";",3)_HDICRLF D SETDATA
- I $O(RERRARY(0))>0 D ;<
- . S HDISTR=HDISTR_HDICRLF_"Error Array Display"_HDICRLF D SETDATA
- . S A=0 F S A=$O(RERRARY(A)) Q:'A S HDISTR=HDISTR_RERRARY(A)_HDICRLF D SETDATA
- I HDISTR'="" S HDINODE=HDINODE+1,@HDISV@(HDINODE)=$$UUEN(HDISTR)
- S @HDISV@(HDINODE+1)=" "
- S @HDISV@(HDINODE+2)="end"
- Q
- ;
- DISTXT ; error text
- ;;Area Not Sent.
- ;;Lookup Value Not Sent.
- ;;Return Value Not Sent.
- ;;Improper Search Area
- ;;Single Item Not Found in ORDERABLE ITEMS File 101.43.
- ;;Single Item Not in Area.
- ;;Partial Lookup Error.
- ;;Orderable Items File Does Not Have Lab Pointer for Item.
- ;;Orderable Item Lab Pointer Not Found in Lab File.
- ;;
- ;;
- ;;Type of Lookup not Sent
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHDISDSR1 3334 printed Feb 18, 2025@23:22:55 Page 2
- HDISDSR1 ;BPFO/DTG - HDI MAILMAN SERVER COLLECT SDO DATA; Apr 07, 2018@12:42
- +1 ;;1.0;HEALTH DATA & INFORMATICS;**22**;Feb 22, 2005;Build 26
- +2 ;
- +3 ;
- INIT ; initialize vars and file
- +1 ;
- +2 ; Uses ICR 5812 to read file 4.3 field 8.3
- +3 ;
- +4 KILL @HDISV
- +5 SET HDITXT=0
- SET HDICRLF=$CHAR(13,10)
- SET HDITAB=$CHAR(9)
- SET HDIJB=$JOB
- SET U="^"
- +6 SET HDISTR=""
- +7 SET HDISITE=$$SITE^VASITE
- SET HDISTN=$PIECE(HDISITE,"^",2)
- SET HDIST=$PIECE(HDISITE,"^",3)
- +8 IF HDIST=""
- SET HDIST="???"
- +9 ;
- +10 SET HDISUB=$$UP^XLFSTR(XQSUB)
- +11 ;get max lines and make character count
- +12 NEW A,B
- SET A=$$GET1^DIQ(4.3,"1,",8.3,"I")
- SET B=$SELECT((+A=0):5469,(A>15000):15000,1:A)
- +13 SET HDIMAX=((B*250)-((B*250)*.3))\1
- +14 ;
- +15 QUIT
- +16 ;
- MAILSEND(HDISUBJ) ; Send extract back to requestor.
- +1 ;
- +2 NEW HDINSTR,HDITASK,HDITO,XMERR,XMZ,A
- +3 ;
- +4 ;ZEXCEPT: XQSND
- +5 ;
- +6 ;S 1=1
- +7 SET HDITO(XQSND)=""
- +8 SET HDINSTR("ADDR FLAGS")="R"
- +9 SET HDINSTR("FROM")="HDI_SDO_CODES"
- +10 SET HDISUBJ=$EXTRACT(HDISUBJ,1,65)
- +11 DO SENDMSG^XMXAPI(.5,HDISUBJ,"^TMP($J,""HDIDATA"")",.HDITO,.HDINSTR,.HDITASK)
- +12 SET A=$GET(^DTGHD("A",0))
- SET A=A+1
- SET ^DTGHD("A",0)=A
- SET ^DTGHD("A",A)=HDITASK
- +13 QUIT
- +14 ;
- ENCODE(HDISTR) ; Encode a string, keep remainder for next line
- +1 ; Call with ORSTR by reference, Remainder returned in LRSTR
- +2 ;
- +3 SET HDIQUIT=0
- SET HDILEN=$LENGTH(HDISTR)
- +4 FOR
- Begin DoDot:1
- +5 IF $LENGTH(HDISTR)<45
- SET HDIQUIT=1
- QUIT
- +6 SET HDIX=$EXTRACT(HDISTR,1,45)
- SET LT=LT+$LENGTH(HDIX)
- +7 SET HDINODE=HDINODE+1
- SET @HDISV@(HDINODE)=$$UUEN(HDIX)
- +8 SET HDISTR=$EXTRACT(HDISTR,46,HDILEN)
- End DoDot:1
- if HDIQUIT
- QUIT
- +9 QUIT
- +10 ;
- UUEN(STR) ; Uuencode string passed in.
- +1 NEW J,K,LEN,HDII,HDIX,S,TMP,X,Y
- +2 SET TMP=""
- SET LEN=$LENGTH(STR)
- +3 FOR HDII=1:3:LEN
- Begin DoDot:1
- +4 SET HDIX=$EXTRACT(STR,HDII,HDII+2)
- +5 IF $LENGTH(HDIX)<3
- SET HDIX=HDIX_$EXTRACT(" ",1,3-$LENGTH(HDIX))
- +6 SET S=$ASCII(HDIX,1)*256+$ASCII(HDIX,2)*256+$ASCII(HDIX,3)
- SET Y=""
- +7 FOR K=0:1:23
- SET Y=(S\(2**K)#2)_Y
- +8 FOR K=1:6:24
- Begin DoDot:2
- +9 SET J=$$DEC^XLFUTL($EXTRACT(Y,K,K+5),2)
- +10 SET TMP=TMP_$CHAR(J+32)
- End DoDot:2
- End DoDot:1
- +11 SET TMP=$CHAR(LEN+32)_TMP
- +12 QUIT TMP
- +13 ;
- UUBEGFN(HDFILENM) ; Construct uuencode "begin" coding
- +1 ; Call with HDFILENM = name of uuencoded file attachment
- +2 ;
- +3 ; Returns HDIX = string with "begin..."_file name
- +4 ;
- +5 NEW HDIX
- +6 SET HDIX="begin 644 "_HDFILENM
- +7 QUIT HDIX
- +8 ;
- +9 ;
- SETDATA ; Set data into report structure
- +1 SET HDINODE=$ORDER(^TMP($JOB,"HDIDATA",""),-1)
- +2 IF HDITXT
- SET HDINODE=HDINODE+1
- SET @HDISV@(HDINODE)=HDISTR
- SET HDISTR=""
- QUIT
- +3 IF 'HDITXT
- DO ENCODE(.HDISTR)
- +4 QUIT
- +5 ;
- CLEAN ; clean up
- +1 DO CLEAN^HDISDSR
- +2 DO ^%ZISC
- +3 QUIT
- +4 ;
- DISER ; display return error type
- +1 IF RERROR=0
- QUIT
- +2 NEW MSG,A,I,B,J,RR
- +3 ; remove multi's of repeating error #'s
- +4 FOR I=1:1
- SET A=$PIECE(RERROR,",",I)
- if A=""
- QUIT
- SET B(A)=""
- +5 ;
- +6 SET J=$ORDER(@HDISV@(""),-1)
- SET J=J+1
- +7 SET @HDISV@(J)=$$UUBEGFN(HDIFER)
- +8 SET HDISTR="ERROR ITEMS FROM HDI SDO LOOKUP"_HDICRLF
- +9 DO SETDATA
- +10 SET A=0
- FOR
- SET A=$ORDER(B(A))
- if 'A
- QUIT
- SET HDISTR=HDISTR_A_") "_$PIECE($TEXT(DISTXT+A),";",3)_HDICRLF
- DO SETDATA
- +11 ;<
- IF $ORDER(RERRARY(0))>0
- Begin DoDot:1
- +12 SET HDISTR=HDISTR_HDICRLF_"Error Array Display"_HDICRLF
- DO SETDATA
- +13 SET A=0
- FOR
- SET A=$ORDER(RERRARY(A))
- if 'A
- QUIT
- SET HDISTR=HDISTR_RERRARY(A)_HDICRLF
- DO SETDATA
- End DoDot:1
- +14 IF HDISTR'=""
- SET HDINODE=HDINODE+1
- SET @HDISV@(HDINODE)=$$UUEN(HDISTR)
- +15 SET @HDISV@(HDINODE+1)=" "
- +16 SET @HDISV@(HDINODE+2)="end"
- +17 QUIT
- +18 ;
- DISTXT ; error text
- +1 ;;Area Not Sent.
- +2 ;;Lookup Value Not Sent.
- +3 ;;Return Value Not Sent.
- +4 ;;Improper Search Area
- +5 ;;Single Item Not Found in ORDERABLE ITEMS File 101.43.
- +6 ;;Single Item Not in Area.
- +7 ;;Partial Lookup Error.
- +8 ;;Orderable Items File Does Not Have Lab Pointer for Item.
- +9 ;;Orderable Item Lab Pointer Not Found in Lab File.
- +10 ;;
- +11 ;;
- +12 ;;Type of Lookup not Sent